!===============================================================================
!
!*** 				INITIAL CONDITIONS			     ***
!
!-------------------------------------------------------------------------------
!Subroutine for initial conditions functions for density, velocity, and pressure
!& as a function of x.
!-------------------------------------------------------------------------------
subroutine init_conds(x,y,z,rho,ux,uy,uz,p)
	use constants								!Tells program to use global constants
	implicit none

		Real*8, intent(in) :: x,y,z
		Real*8, intent(out) :: rho,ux,uy,uz,p
		Real*8 :: delx,dely,delz					!Ranges in x, y and z for the maximum range limit
		Real*8 :: d							!Thickness of zero velocity layer

		real*8,external::isotherm_p

		Real*8 :: exp_blob,Dmax,Rhomax,RhoMin
		Real*8 :: x0,y0,z0,rhoblob,dblob

		Real*8 :: xarg,yarg,zarg,dist
		Integer :: i
		Real*8 :: p_BackGround,rho_BackGround				!Background Pressure & density for Adiabatic and Two Phase Isothermal Setups

!	Cells format: 	cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)

	delx=xrangeMax-xrangeMin
	dely=yrangeMax-yrangeMin
	delz=zrangeMax-zrangeMin

!	Set thickness of zero velocity layer:
	d=0.375d0

!	Set background phase Pressure and Density:
	p_BackGround=rhominset*(CsIso**2)
	rho_BackGround=rhominset

!	Set e blob to 2 to achieve circular regions:
	exp_blob=2
!	Set max diameter of blob:
	Dmax=DmaxSet
!	Set max density of blob:
	rhomax=RhomaxSet
!	Set Background Density :
	RhoMin=RhominSet

	If ((RandBlobBool.eqv..true.).AND.(BlobSwitchBool.eqv..TRUE.)) then
!	Allocate arrays the dimension of number of blobs being used:
		allocate (x0_blob_array(NumBlobs))
		allocate (y0_blob_array(NumBlobs))
		allocate (z0_blob_array(NumBlobs))
		allocate (d_blob_array(NumBlobs))
		allocate (rho_blob_array(NumBlobs))

		call rand_blobs(d,dmax,rhomax)
	endif
!	Switch off any further calls to generate random blob regions:
	RandBlobBool=.false.

!-------------------------------------------------------------------------------
!	Setup Background Atmosphere
!-------------------------------------------------------------------------------

	rho = RhoMin

!	Set Isothermal Pressure
	If (IsoBool.eqv..TRUE.) then
		p = isotherm_p(rho)
	else
		p=p_BackGround
	endif

	If ((x>=0.d0).and.(x<=0.d0+d)) then
		If (IsoBool.eqv..TRUE.) then
			ux=+1.5d0*DSQRT((p_BackGround/rho_BackGround))
		else if (IsoBool.eqv..FALSE.) then
			ux=+1.5d0*DSQRT(gam*(p/rho))
		endif
		uy=0.d0
		uz=0.d0
	else if ((x>=delx-d).and.(x<=delx)) then
		If (IsoBool.eqv..TRUE.) then
			ux=-1.5d0*DSQRT((p_BackGround/rho_BackGround))
		else if (IsoBool.eqv..FALSE.) then
			ux=-1.5d0*DSQRT(gam*(p/rho))
		endif
		uy=0.d0
		uz=0.d0
	else
		ux=0.d0
		uy=0.d0
		uz=0.d0
	endif

!-------------------------------------------------------------------------------
!	Setup Blobs based on randomly generated conditions:
!-------------------------------------------------------------------------------
	IF (BlobSwitchBool.eqv..TRUE.) then
		Do while (i<=NumBlobs)
	!	Get data from blob arrays previously randomly generated:
			x0 = x0_blob_array(i)
			y0 = y0_blob_array(i)
			z0 = z0_blob_array(i)
			dblob = d_blob_array(i)
			rhoblob = rho_blob_array(i)

	!	Dist(x-vec,o-vec) = [((x_x-o_x)/(0.5d0*d_x))**e+((x_y-o_y)/(0.5d0*d_y))**e+((x_x-o_z)/(0.5d0*d_z))**e]**(1/e)
	!	If Dist<=1 point is inside region
			zarg=((z-z0)/(0.5d0*dblob))**exp_blob
			yarg = ((y-y0)/(0.5d0*dblob))**exp_blob
			xarg = ((x-x0)/(0.5d0*dblob))**exp_blob
			dist = (zarg+yarg+xarg)**(1.d0/exp_blob)

			If ((x0.gt.(dblob+0.02d0)).and.(x0.lt.(delx-(dblob+0.02d0))).and.(dist<=1.d0)) then
				rho = rhoblob
				uy= 0.d0
				uz=0.d0
				If (IsoBool.eqv..TRUE.) then
					p = isotherm_p(rho)
				else
					p=p_BackGround
				endif
			endif
			i=i+1
		enddo
	endif

end subroutine init_conds

!===============================================================================

!===============================================================================
!#####		RANDOMLY GENERATE DENSE COLD BLOB REGIONS		########
!===============================================================================

subroutine rand_blobs(d,dmax,rhomax)
	use constants								!Tells program to use global constants
	implicit none

		Real*8,intent(in) :: d,dmax,rhomax
		Real*8 :: dblob,rho,exp_blob,x0,y0,z0
		Real*8 :: rand_num
		Real*8 :: delx,dely,delz					!Ranges in x, y and z for the maximum range limit
		Integer :: i

	delx=xrangeMax-xrangeMin
	dely=yrangeMax-yrangeMin
	delz=zrangeMax-zrangeMin

	call srand(RandSeed)

	i=1

!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
!	Generate Blobs:
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
	Do while (i<=NumBlobs)
		101 CONTINUE
		Print'(A15,1x,I3.3,1x,A2,1x,I3.3)',"Generating Blob",i,"of",NumBlobs

!	Generate a random number:
		rand_num = rand(0)
!-------------------------------------------------------------------------------
!	Setup Diameter:
!-------------------------------------------------------------------------------
		If (rand_num.gt.0.d0) then
!	Set diameter of blob:
			dblob = rand_num*dmax
		else
!	The loop will restart to call a new random number if the diameter is zero
			GOTO 101
		endif
!-------------------------------------------------------------------------------
!	Set Centre of region:
!-------------------------------------------------------------------------------
		102 CONTINUE
		rand_num = rand(0)
!		If the x cooridinate lies outside of the wind regions a new x coord will be calculated:
!		Also checks that the x coord is not too close to the boundary:
		If ( (((rand_num*delx).gt.(dblob+0.02d0)).and.((rand_num*delx).lt.(d)))&
		.or.(((rand_num*delx).lt.(delx-(dblob+0.02d0))).and.((rand_num*delx).gt.(delx-d)))) then
				x0 = rand_num*delx
		else
			GOTO 102
		endif

		103 CONTINUE
		rand_num = rand(0)
!		If the y cooridinate lies too close to the bounaries:
		If (((rand_num*dely).gt.(dblob+0.02d0)).and.((rand_num*dely).lt.(dely-(dblob+0.02d0)))) then
			y0 = rand_num*dely
		else
			GOTO 103
		endif

		104 CONTINUE
		rand_num = rand(0)
!		If the z cooridinate lies too close to the bounaries:
		If (((rand_num*delz).gt.(dblob+0.02d0)).and.((rand_num*delz).lt.(delz-(dblob+0.02d0)))) then
			z0 = rand_num*delz
		else
			GOTO 104
		endif

!-------------------------------------------------------------------------------
!	Set Density of Region:
!-------------------------------------------------------------------------------
		If (TwoPhaseBool .eqv. .FALSE.) then
			105 CONTINUE
			rand_num = rand(0)
	!		If the density is non-zero and above critical density for two phase, set density as fraction of maximum density:
			If ((rand_num.gt.0.d0).and.((rand_num*RhoMax).ge.RhoCrit)) then
				rho = rand_num*rhomax
			else
				GOTO 105
			endif
		else if (TwoPhaseBool .eqv. .TRUE.) then
			rho=rhomax
		endif
!-------------------------------------------------------------------------------
!	Set Variables into arrays:
!-------------------------------------------------------------------------------
!	Allocate above variables to blob arrays:
	x0_blob_array(i) = x0
	y0_blob_array(i) = y0
	z0_blob_array(i) = z0
	d_blob_array(i) = dblob
	rho_blob_array(i) = rho

		i=i+1
	enddo

end subroutine rand_blobs


#include "Definitions.INC"

module hr_grammod
contains

!! allows real valued indefinite (possibly negative) inner product.
!!  norm of vector (1 or -1) output in mysign.
!!  vectors 1:m need to be orthonormal
!!  their norms are in prevsigns(1:m)

subroutine myhgramschmidt_many(n, howmany, m, previous, vector,inalldotsub,prevsigns,mysign,myfactors)
  use fileptrmod
  implicit none

! n is the length of the vectors; m is how many to orthogonalize to

  integer :: n,m,mysign,prevsigns(m),howmany
  DATATYPE :: previous(n,howmany,m), vector(n,howmany),tempdots(m,howmany),myhdots(m,1),&
       tempprev(n,m,howmany)
  real*8 :: myfactors(howmany)
  integer :: i,j,k
  DATATYPE :: norm,temp(1,1)
  external :: inalldotsub

  do i=1,howmany
     tempprev(:,:,i)=previous(:,i,:)
  enddo
  do j=1,2
     if (m.ne.0) then
        myhdots(:,:)=0d0
        do k=1,howmany
           call inalldotsub(tempprev(:,:,k),vector(:,k),n,m,1,tempdots(:,k))
           myhdots(:,1)=myhdots(:,1)+tempdots(:,k)*myfactors(k)
        enddo
     endif
     do i=1,m
       vector(:,:)=vector-previous(:,:,i)* myhdots(i,1) * prevsigns(i)
     enddo
     norm=0d0
     do k=1,howmany
        call inalldotsub(vector(:,k),vector(:,k),n,1,1,temp)
        norm=norm+temp(1,1)*myfactors(k)
     enddo
     if (abs(imag(norm)).gt.abs(real(norm,8))*1d-8) then
        OFLWR "AAUG IMAGNORM ", norm
     endif
     if (real(norm,8).ge.0d0) then
        mysign= 1
     else
        mysign= (-1)
     endif
     norm=sqrt(abs(norm))
     vector=vector/norm
     if (abs(norm).lt.1e-7) then
        OFLWR "Gram schmidt norm",norm,m; CFL
     endif
  enddo

end subroutine myhgramschmidt_many

end module hr_grammod

module hr_setmod

contains

subroutine fast_harmritz_setup( &
     lanblocknum, lansize,order,maxiter,initvectors,etarget,&
     inprintflag,&
     inh0multsub,indotsub,&
     lanham,lansimpleham,lansimpleovl,lansimplemultovl,lanvects)
  use hr_grammod
  use fileptrmod
  implicit none

  integer,intent(in) :: lansize,maxiter,lanblocknum,inprintflag,order
  external :: inh0multsub,indotsub
  integer, parameter :: manynum=2
  DATATYPE, intent(in) ::       initvectors(lansize,lanblocknum),etarget
  DATATYPE ::       lanham(lanblocknum,order,lanblocknum,order),lansimpleham(lanblocknum,order,lanblocknum,order),&
       lansimpleovl(lanblocknum,order,lanblocknum,order),lansimplemultovl(lanblocknum,order,lanblocknum,order),&
       lanvects(lansize,lanblocknum,order), &
       lansimplemultvects(lansize,lanblocknum,order), lanmanyvects(lansize,manynum,lanblocknum,order)
  real*8 :: factors(manynum)
  integer ::  iorder,i,thislanblocknum, printflag,lansigns(lanblocknum,order)

!! should be okay actually
  if (order*lanblocknum.gt.maxiter) then
     OFLWR "What in the world?  Order*lanblocknum is greater than lansize.", order,lanblocknum,lansize; CFLST
  endif

  printflag=inprintflag

  do iorder=1,order

!! DOES PARTIAL BLOCK IF AT THE END (leaving this)
     thislanblocknum=lanblocknum
     if (iorder*lanblocknum.ge.maxiter) then
        thislanblocknum=maxiter-(iorder-1)*lanblocknum
     endif
     if (iorder.eq.1) then
        lanvects(:,:,1)=initvectors(:,:)
     else
        call inh0multsub(thislanblocknum,lanvects(:,:,iorder-1),lanvects(:,:,iorder))
     endif

     call inh0multsub(thislanblocknum,lanvects(:,:,iorder),lansimplemultvects(:,:,iorder))

     lansimplemultvects(:,:,iorder)=lansimplemultvects(:,:,iorder)-etarget*lanvects(:,:,iorder)
     lanmanyvects(:,1,:,:)=lansimplemultvects(:,:,:)
     lanmanyvects(:,2,:,:)=lanvects(:,:,:)
     factors(1)=1d0
     factors(2)=0d0
!!$     factors(2)=(-1)*abs(etarget)**2

     do i=1,thislanblocknum
        call myhgramschmidt_many(lansize, manynum, (iorder-1)*lanblocknum+i-1,  &
             lanmanyvects,lanmanyvects(:,:,i,iorder),&
             indotsub,lansigns,lansigns(i,iorder),factors)
     enddo

     lansimplemultvects(:,:,:)=lanmanyvects(:,1,:,:)
     lanvects(:,:,:)=lanmanyvects(:,2,:,:)

  enddo

  call indotsub(lansimplemultvects(:,:,:),lanvects(:,:,:),lansize,order*lanblocknum,order*lanblocknum,lanham)

  do iorder=1,order
     do i=1,lanblocknum
        lanham(:,:,i,iorder)=lanham(:,:,i,iorder)*lansigns(:,:)
     enddo
  enddo

  call indotsub(lanvects(:,:,:),lanvects(:,:,:),lansize,order*lanblocknum,order*lanblocknum,lansimpleovl)
  lansimplemultvects(:,:,:)=lansimplemultvects(:,:,:)+etarget*lanvects(:,:,:)
  call indotsub(lanvects(:,:,:),lansimplemultvects(:,:,:),lansize,order*lanblocknum,order*lanblocknum,lansimpleham)
  call indotsub(lansimplemultvects(:,:,:),lansimplemultvects(:,:,:),lansize,order*lanblocknum,order*lanblocknum,lansimplemultovl)

end subroutine fast_harmritz_setup

subroutine harm_orthog_oneblock(invects, &
     lanblocknum, lansize,etarget,&
     inprintflag,&
     inh0multsub,indotsub,&
     lantrans)
  use hr_grammod
  use hr_eigenmod
  implicit none

  integer,intent(in) :: lansize,lanblocknum,inprintflag
  external :: inh0multsub,indotsub
  integer, parameter :: manynum=2
  DATATYPE, intent(in) :: etarget
  DATATYPE ::    invects(lansize,lanblocknum), tempvects(lansize,lanblocknum), &
       lantrans(lanblocknum,lanblocknum),&
       lantransinv(lanblocknum,lanblocknum),&
       tempdots(lanblocknum,lanblocknum),&
       indots(lanblocknum,lanblocknum),&
       lansimplemultvects(lansize,lanblocknum)
  integer ::  i,printflag,j,k

  printflag=inprintflag

  call inh0multsub(lanblocknum,invects(:,:),lansimplemultvects(:,:))

  lansimplemultvects(:,:)=lansimplemultvects(:,:)-etarget*invects(:,:)
  call indotsub(lansimplemultvects(:,:),lansimplemultvects(:,:),lansize,lanblocknum,lanblocknum,indots)
  lantransinv(:,:)=indots(:,:)

!! BUGGY ON EDISON WITH GNU COMPILERS (OR DJH MAKEFILE OR MODULES ERROR)
!!   zgesdd, zgesvd, zgeev

#ifndef REALGO

!!$ print *, "eeeeg"
!!$  call invsqrtmat(lantransinv,lanblocknum)

!!TEMP?    call hermsqrtmatsmooth(lantransinv,lantrans,lanblocknum,lanblocknum,0d-10)

!!TEMP?:
!  lantrans(:,:)=lantransinv(:,:)
  call cnormorthogmat(lantransinv,lanblocknum)

!!!  print *, "ooof";stop

  call ZGEMM('N','C',lansize,lanblocknum,lanblocknum,(1d0,0d0),invects,lansize,lantransinv,lanblocknum,&
       (0d0,0d0),tempvects,lansize)

!!! print *, "laaapf"

!!$ print *, "ooguuu"
!!$    call symorthogmat(lantransinv,lanblocknum)
!!$ print *, "fsfds88";stop
!!$    call ZGEMM('N','N',lansize,lanblocknum,lanblocknum,(1d0,0d0),invects,lansize,lantransinv,lanblocknum,&
!!$        (0d0,0d0),tempvects,lansize)

#else
  call realsqrtmatsmooth(lantransinv,lantrans,lanblocknum,lanblocknum,0d-10)
  call DGEMM('N','T',lansize,lanblocknum,lanblocknum,1d0,invects,lansize,lantransinv,lanblocknum,&
       0d0,tempvects,lansize)
#endif

  invects(:,:)=tempvects(:,:)

!! check

  call inh0multsub(lanblocknum,invects(:,:),lansimplemultvects(:,:))

  lansimplemultvects(:,:)=lansimplemultvects(:,:)-etarget*invects(:,:)

  call indotsub(lansimplemultvects(:,:),lansimplemultvects(:,:),lansize,lanblocknum,lanblocknum,tempdots)
  do i=1,lanblocknum
      tempdots(i,i)=tempdots(i,i)-1d0
  enddo

  do i=1,lanblocknum
     do j=1,lanblocknum
        if (abs(tempdots(i,j)).gt.1d-8) then
           print *, "AACK DOTS:"
           do k=1,lanblocknum
              write(*,'(100E20.3)') tempdots(:,k)
           enddo
           stop
        endif
     enddo
  enddo

end subroutine harm_orthog_oneblock

end module hr_setmod

!! GMRES LINEAR SOLVE.

!! fixed order, no restart, not for solving things per se, just a finite-order approximation
!!  to the inverse, error unchecked.

module hr_basicsolvemod

contains

subroutine basicblocklansolve(&
     lanblocknum, lansize,order, maxiter, invectors, outvectors, &
     inprintflag,&
     inh0multsub,indotsub,     etarget)
  use hr_setmod
  use hr_eigenmod
  use fileptrmod
  implicit none

  integer,intent(in) :: lansize,maxiter,lanblocknum,inprintflag,order
  DATATYPE, intent(in) :: etarget,invectors(lansize,lanblocknum)
  DATATYPE, intent(out) :: outvectors(lansize,lanblocknum)
  DATATYPE ::   initvectors(lansize,lanblocknum), &
       lanham(lanblocknum*order,lanblocknum*order),lansimpleovl(lanblocknum*order,lanblocknum*order),&
       lansimplemultovl(lanblocknum,order,lanblocknum,order),&
       lansimpleham(lanblocknum,order,lanblocknum,order),&
       lanvects(lansize,lanblocknum,order),        lantrans(lanblocknum,lanblocknum), &
       solvevecs(lanblocknum,order,lanblocknum),&
       rhs(lanblocknum,order,lanblocknum)
  integer ::  thisdim,printflag
  external :: inh0multsub,indotsub

  if (order.le.0) then
     print *, "ORDERERROR", order; stop
  endif

!! should be okay actually
  if (order*lanblocknum.gt.maxiter) then
     OFLWR "What in the world?  Order*lanblocknum is greater than lansize.", order,lanblocknum,lansize; CFLST
  endif

  printflag=inprintflag
  thisdim=min(maxiter,order*lanblocknum)

  initvectors(:,:)=invectors(:,:)

!!$  print *, "HHARMorth"

  call harm_orthog_oneblock(initvectors, &
       lanblocknum, lansize,etarget,&
       inprintflag,&
       inh0multsub,indotsub,&
       lantrans)

!!$  print *, "okaay..."; stop

  call fast_harmritz_setup( &
       lanblocknum, lansize,order,maxiter,initvectors,etarget,&
       inprintflag,&
       inh0multsub,indotsub,&
       lanham,lansimpleham,lansimpleovl,lansimplemultovl,lanvects)

  rhs(:,:,:)=0d0
  rhs(:,1,:)=lantrans(:,:)

#ifndef REALGO
  call ZGEMM('N','N',thisdim,lanblocknum,thisdim,(1d0,0d0),lanham(:,:),order*lanblocknum,rhs,order*lanblocknum,&
       (0d0,0d0),solvevecs,order*lanblocknum)
  call ZGEMM('N','N',lansize,lanblocknum,thisdim,(1d0,0d0),lanvects(:,:,:),lansize,solvevecs,order*lanblocknum,&
       (0d0,0d0),outvectors,lansize)
#else
  call DGEMM('N','N',thisdim,lanblocknum,thisdim,1d0,lanham(:,:),order*lanblocknum,rhs,order*lanblocknum,&
       0d0,solvevecs,order*lanblocknum)
  call DGEMM('N','N',lansize,lanblocknum,thisdim,1d0,lanvects(:,:,:),lansize,solvevecs,order*lanblocknum,&
       0d0,outvectors,lansize)
#endif

end subroutine basicblocklansolve

end module hr_basicsolvemod


      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
     $                   LDU, C, LDC, WORK, INFO )
*
*  -- LAPACK routine (instrumented to count operations, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*     Common block to return operation count and iteration count
*     ITCNT is initialized to 0, OPS is only incremented
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      DOUBLE PRECISION   ITCNT, OPS
*     ..
*
*  Purpose
*  =======
*
*  DBDSQR computes the singular value decomposition (SVD) of a real
*  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P'
*  denotes the transpose of P), where S is a diagonal matrix with
*  non-negative diagonal elements (the singular values of B), and Q
*  and P are orthogonal matrices.
*
*  The routine computes S, and optionally computes U * Q, P' * VT,
*  or Q' * C, for given real input matrices U, VT, and C.
*
*  See "Computing  Small Singular Values of Bidiagonal Matrices With
*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
*  no. 5, pp. 873-912, Sept 1990) and
*  "Accurate singular values and differential qd algorithms," by
*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
*  Department, University of California at Berkeley, July 1992
*  for a detailed description of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  B is upper bidiagonal;
*          = 'L':  B is lower bidiagonal.
*
*  N       (input) INTEGER
*          The order of the matrix B.  N >= 0.
*
*  NCVT    (input) INTEGER
*          The number of columns of the matrix VT. NCVT >= 0.
*
*  NRU     (input) INTEGER
*          The number of rows of the matrix U. NRU >= 0.
*
*  NCC     (input) INTEGER
*          The number of columns of the matrix C. NCC >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the n diagonal elements of the bidiagonal matrix B.
*          On exit, if INFO=0, the singular values of B in decreasing
*          order.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the elements of E contain the
*          offdiagonal elements of the bidiagonal matrix whose SVD
*          is desired. On normal exit (INFO = 0), E is destroyed.
*          If the algorithm does not converge (INFO > 0), D and E
*          will contain the diagonal and superdiagonal elements of a
*          bidiagonal matrix orthogonally equivalent to the one given
*          as input. E(N) is used for workspace.
*
*  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
*          On entry, an N-by-NCVT matrix VT.
*          On exit, VT is overwritten by P' * VT.
*          VT is not referenced if NCVT = 0.
*
*  LDVT    (input) INTEGER
*          The leading dimension of the array VT.
*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*
*  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N)
*          On entry, an NRU-by-N matrix U.
*          On exit, U is overwritten by U * Q.
*          U is not referenced if NRU = 0.
*
*  LDU     (input) INTEGER
*          The leading dimension of the array U.  LDU >= max(1,NRU).
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
*          On entry, an N-by-NCC matrix C.
*          On exit, C is overwritten by Q' * C.
*          C is not referenced if NCC = 0.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C.
*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  If INFO = -i, the i-th argument had an illegal value
*          > 0:  the algorithm did not converge; D and E contain the
*                elements of a bidiagonal matrix which is orthogonally
*                similar to the input matrix B;  if INFO = i, i
*                elements of E have not converged to zero.
*
*  Internal Parameters
*  ===================
*
*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
*          TOLMUL controls the convergence criterion of the QR loop.
*          If it is positive, TOLMUL*EPS is the desired relative
*             precision in the computed singular values.
*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
*             desired absolute accuracy in the computed singular
*             values (corresponds to relative accuracy
*             abs(TOLMUL*EPS) in the largest singular value.
*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
*             between 10 (for fast convergence) and .1/EPS
*             (for there to be some accuracy in the results).
*          Default is to lose at either one eighth or 2 of the
*             available decimal digits in each computed singular value
*             (whichever is smaller).
*
*  MAXITR  INTEGER, default = 6
*          MAXITR controls the maximum number of passes of the
*          algorithm through its inner loop. The algorithms stops
*          (and so fails to converge) if the number of passes
*          through the inner loop exceeds MAXITR*N**2.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   NEGONE
      PARAMETER          ( NEGONE = -1.0D0 )
      DOUBLE PRECISION   HNDRTH
      PARAMETER          ( HNDRTH = 0.01D0 )
      DOUBLE PRECISION   TEN
      PARAMETER          ( TEN = 10.0D0 )
      DOUBLE PRECISION   HNDRD
      PARAMETER          ( HNDRD = 100.0D0 )
      DOUBLE PRECISION   MEIGTH
      PARAMETER          ( MEIGTH = -0.125D0 )
      INTEGER            MAXITR
      PARAMETER          ( MAXITR = 6 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, ROTATE
      INTEGER            I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
     $                   NM12, NM13, OLDLL, OLDM
      DOUBLE PRECISION   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA,
     $                   SN, THRESH, TOL, TOLMUL, UNFL
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,
     $                   DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SIGN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      LOWER = LSAME( UPLO, 'L' )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NCVT.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRU.LT.0 ) THEN
         INFO = -4
      ELSE IF( NCC.LT.0 ) THEN
         INFO = -5
      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
         INFO = -9
      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
         INFO = -11
      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DBDSQR', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 )
     $   RETURN
      IF( N.EQ.1 )
     $   GO TO 160
*
*     ROTATE is true if any singular vectors desired, false otherwise
*
      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
*     If no singular vectors desired, use qd algorithm
*
      IF( .NOT.ROTATE ) THEN
         CALL DLASQ1( N, D, E, WORK, INFO )
         RETURN
      END IF
*
      NM1 = N - 1
      NM12 = NM1 + NM1
      NM13 = NM12 + NM1
      IDIR = 0
*
*     Get machine constants
*
      EPS = DLAMCH( 'Epsilon' )
      UNFL = DLAMCH( 'Safe minimum' )
*
*     If matrix lower bidiagonal, rotate to be upper bidiagonal
*     by applying Givens rotations on the left
*
      IF( LOWER ) THEN
         OPS = OPS + DBLE( N-1 )*( 8+6*( NRU+NCC ) )
         DO 10 I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            WORK( I ) = CS
            WORK( NM1+I ) = SN
   10    CONTINUE
*
*        Update singular vectors if desired
*
         IF( NRU.GT.0 )
     $      CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
     $                  LDU )
         IF( NCC.GT.0 )
     $      CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
     $                  LDC )
      END IF
*
*     Compute singular values to relative accuracy TOL
*     (By setting TOL to be negative, algorithm will compute
*     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
      OPS = OPS + 4
      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
      TOL = TOLMUL*EPS
*
*     Compute approximate maximum, minimum singular values
*
      SMAX = ZERO
      DO 20 I = 1, N
         SMAX = MAX( SMAX, ABS( D( I ) ) )
   20 CONTINUE
      DO 30 I = 1, N - 1
         SMAX = MAX( SMAX, ABS( E( I ) ) )
   30 CONTINUE
      SMINL = ZERO
      IF( TOL.GE.ZERO ) THEN
*
*        Relative accuracy desired
*
         SMINOA = ABS( D( 1 ) )
         IF( SMINOA.EQ.ZERO )
     $      GO TO 50
         MU = SMINOA
         OPS = OPS + 3*N - 1
         DO 40 I = 2, N
            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
            SMINOA = MIN( SMINOA, MU )
            IF( SMINOA.EQ.ZERO )
     $         GO TO 50
   40    CONTINUE
   50    CONTINUE
         SMINOA = SMINOA / SQRT( DBLE( N ) )
         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
      ELSE
*
*        Absolute accuracy desired
*
         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
      END IF
*
*     Prepare for main iteration loop for the singular values
*     (MAXIT is the maximum number of passes through the inner
*     loop permitted before nonconvergence signalled.)
*
      MAXIT = MAXITR*N*N
      ITER = 0
      OLDLL = -1
      OLDM = -1
*
*     M points to last element of unconverged part of matrix
*
      M = N
*
*     Begin main iteration loop
*
   60 CONTINUE
*
*     Check for convergence or exceeding iteration count
*
      IF( M.LE.1 )
     $   GO TO 160
      IF( ITER.GT.MAXIT )
     $   GO TO 200
*
*     Find diagonal block of matrix to work on
*
      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
     $   D( M ) = ZERO
      SMAX = ABS( D( M ) )
      SMIN = SMAX
      DO 70 LLL = 1, M - 1
         LL = M - LLL
         ABSS = ABS( D( LL ) )
         ABSE = ABS( E( LL ) )
         IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
     $      D( LL ) = ZERO
         IF( ABSE.LE.THRESH )
     $      GO TO 80
         SMIN = MIN( SMIN, ABSS )
         SMAX = MAX( SMAX, ABSS, ABSE )
   70 CONTINUE
      LL = 0
      GO TO 90
   80 CONTINUE
      E( LL ) = ZERO
*
*     Matrix splits since E(LL) = 0
*
      IF( LL.EQ.M-1 ) THEN
*
*        Convergence of bottom singular value, return to top of loop
*
         M = M - 1
         GO TO 60
      END IF
   90 CONTINUE
      LL = LL + 1
*
*     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
      IF( LL.EQ.M-1 ) THEN
*
*        2 by 2 block, handle separately
*
         OPS = OPS + 37 + 6*( NCVT+NRU+NCC )
         CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
     $                COSR, SINL, COSL )
         D( M-1 ) = SIGMX
         E( M-1 ) = ZERO
         D( M ) = SIGMN
*
*        Compute singular vectors, if desired
*
         IF( NCVT.GT.0 )
     $      CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
     $                 SINR )
         IF( NRU.GT.0 )
     $      CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
         IF( NCC.GT.0 )
     $      CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
     $                 SINL )
         M = M - 2
         GO TO 60
      END IF
*
*     If working on new submatrix, choose shift direction
*     (from larger end diagonal element towards smaller)
*
      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
*           Chase bulge from top (big end) to bottom (small end)
*
            IDIR = 1
         ELSE
*
*           Chase bulge from bottom (big end) to top (small end)
*
            IDIR = 2
         END IF
      END IF
*
*     Apply convergence tests
*
      IF( IDIR.EQ.1 ) THEN
*
*        Run convergence test in forward direction
*        First apply standard test to bottom of matrix
*
         OPS = OPS + 1
         IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
     $       ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
            E( M-1 ) = ZERO
            GO TO 60
         END IF
*
         IF( TOL.GE.ZERO ) THEN
*
*           If relative accuracy desired,
*           apply convergence criterion forward
*
            MU = ABS( D( LL ) )
            SMINL = MU
            DO 100 LLL = LL, M - 1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 60
               END IF
               SMINLO = SMINL
               OPS = OPS + 4
               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
  100       CONTINUE
         END IF
*
      ELSE
*
*        Run convergence test in backward direction
*        First apply standard test to top of matrix
*
         OPS = OPS + 1
         IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
     $       ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
            E( LL ) = ZERO
            GO TO 60
         END IF
*
         IF( TOL.GE.ZERO ) THEN
*
*           If relative accuracy desired,
*           apply convergence criterion backward
*
            MU = ABS( D( M ) )
            SMINL = MU
            DO 110 LLL = M - 1, LL, -1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 60
               END IF
               SMINLO = SMINL
               OPS = OPS + 4
               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
  110       CONTINUE
         END IF
      END IF
      OLDLL = LL
      OLDM = M
*
*     Compute shift.  First, test if shifting would ruin relative
*     accuracy, and if so set the shift to zero.
*
      OPS = OPS + 4
      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
     $    MAX( EPS, HNDRTH*TOL ) ) THEN
*
*        Use a zero shift to avoid loss of relative accuracy
*
         SHIFT = ZERO
      ELSE
*
*        Compute the shift from 2-by-2 block at end of matrix
*
         OPS = OPS + 20
         IF( IDIR.EQ.1 ) THEN
            SLL = ABS( D( LL ) )
            CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
         ELSE
            SLL = ABS( D( M ) )
            CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
         END IF
*
*        Test if shift negligible, and if so set to zero
*
         IF( SLL.GT.ZERO ) THEN
            IF( ( SHIFT / SLL )**2.LT.EPS )
     $         SHIFT = ZERO
         END IF
      END IF
*
*     Increment iteration count
*
      ITER = ITER + M - LL
*
*     If SHIFT = 0, do simplified QR iteration
*
      IF( SHIFT.EQ.ZERO ) THEN
         OPS = OPS + 2 + DBLE( M-LL )*( 20+6*( NCVT+NRU+NCC ) )
         IF( IDIR.EQ.1 ) THEN
*
*           Chase bulge from top to bottom
*           Save cosines and sines for later singular vector updates
*
            CS = ONE
            OLDCS = ONE
            DO 120 I = LL, M - 1
               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
               IF( I.GT.LL )
     $            E( I-1 ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
               WORK( I-LL+1 ) = CS
               WORK( I-LL+1+NM1 ) = SN
               WORK( I-LL+1+NM12 ) = OLDCS
               WORK( I-LL+1+NM13 ) = OLDSN
  120       CONTINUE
            H = D( M )*CS
            D( M ) = H*OLDCS
            E( M-1 ) = H*OLDSN
*
*           Update singular vectors
*
            IF( NCVT.GT.0 )
     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
     $                     WORK( N ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
     $                     WORK( NM13+1 ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
     $                     WORK( NM13+1 ), C( LL, 1 ), LDC )
*
*           Test convergence
*
            IF( ABS( E( M-1 ) ).LE.THRESH )
     $         E( M-1 ) = ZERO
*
         ELSE
*
*           Chase bulge from bottom to top
*           Save cosines and sines for later singular vector updates
*
            CS = ONE
            OLDCS = ONE
            DO 130 I = M, LL + 1, -1
               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
               IF( I.LT.M )
     $            E( I ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
               WORK( I-LL ) = CS
               WORK( I-LL+NM1 ) = -SN
               WORK( I-LL+NM12 ) = OLDCS
               WORK( I-LL+NM13 ) = -OLDSN
  130       CONTINUE
            H = D( LL )*CS
            D( LL ) = H*OLDCS
            E( LL ) = H*OLDSN
*
*           Update singular vectors
*
            IF( NCVT.GT.0 )
     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
     $                     WORK( N ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
     $                     WORK( N ), C( LL, 1 ), LDC )
*
*           Test convergence
*
            IF( ABS( E( LL ) ).LE.THRESH )
     $         E( LL ) = ZERO
         END IF
      ELSE
*
*        Use nonzero shift
*
         OPS = OPS + 2 + ( M-LL )*( 32+6*( NCVT+NRU+NCC ) )
         IF( IDIR.EQ.1 ) THEN
*
*           Chase bulge from top to bottom
*           Save cosines and sines for later singular vector updates
*
            F = ( ABS( D( LL ) )-SHIFT )*
     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
            G = E( LL )
            DO 140 I = LL, M - 1
               CALL DLARTG( F, G, COSR, SINR, R )
               IF( I.GT.LL )
     $            E( I-1 ) = R
               F = COSR*D( I ) + SINR*E( I )
               E( I ) = COSR*E( I ) - SINR*D( I )
               G = SINR*D( I+1 )
               D( I+1 ) = COSR*D( I+1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( I ) = R
               F = COSL*E( I ) + SINL*D( I+1 )
               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
               IF( I.LT.M-1 ) THEN
                  G = SINL*E( I+1 )
                  E( I+1 ) = COSL*E( I+1 )
               END IF
               WORK( I-LL+1 ) = COSR
               WORK( I-LL+1+NM1 ) = SINR
               WORK( I-LL+1+NM12 ) = COSL
               WORK( I-LL+1+NM13 ) = SINL
  140       CONTINUE
            E( M-1 ) = F
*
*           Update singular vectors
*
            IF( NCVT.GT.0 )
     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
     $                     WORK( N ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
     $                     WORK( NM13+1 ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
     $                     WORK( NM13+1 ), C( LL, 1 ), LDC )
*
*           Test convergence
*
            IF( ABS( E( M-1 ) ).LE.THRESH )
     $         E( M-1 ) = ZERO
*
         ELSE
*
*           Chase bulge from bottom to top
*           Save cosines and sines for later singular vector updates
*
            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
     $          D( M ) )
            G = E( M-1 )
            DO 150 I = M, LL + 1, -1
               CALL DLARTG( F, G, COSR, SINR, R )
               IF( I.LT.M )
     $            E( I ) = R
               F = COSR*D( I ) + SINR*E( I-1 )
               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
               G = SINR*D( I-1 )
               D( I-1 ) = COSR*D( I-1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( I ) = R
               F = COSL*E( I-1 ) + SINL*D( I-1 )
               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
               IF( I.GT.LL+1 ) THEN
                  G = SINL*E( I-2 )
                  E( I-2 ) = COSL*E( I-2 )
               END IF
               WORK( I-LL ) = COSR
               WORK( I-LL+NM1 ) = -SINR
               WORK( I-LL+NM12 ) = COSL
               WORK( I-LL+NM13 ) = -SINL
  150       CONTINUE
            E( LL ) = F
*
*           Test convergence
*
            IF( ABS( E( LL ) ).LE.THRESH )
     $         E( LL ) = ZERO
*
*           Update singular vectors if desired
*
            IF( NCVT.GT.0 )
     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
     $                     WORK( N ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
     $                     WORK( N ), C( LL, 1 ), LDC )
         END IF
      END IF
*
*     QR iteration finished, go back and check convergence
*
      GO TO 60
*
*     All singular values converged, so make them positive
*
  160 CONTINUE
      DO 170 I = 1, N
         IF( D( I ).LT.ZERO ) THEN
            D( I ) = -D( I )
*
*           Change sign of singular vectors, if desired
*
            OPS = OPS + NCVT
            IF( NCVT.GT.0 )
     $         CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
         END IF
  170 CONTINUE
*
*     Sort the singular values into decreasing order (insertion sort on
*     singular values, but only one transposition per singular vector)
*
      DO 190 I = 1, N - 1
*
*        Scan for smallest D(I)
*
         ISUB = 1
         SMIN = D( 1 )
         DO 180 J = 2, N + 1 - I
            IF( D( J ).LE.SMIN ) THEN
               ISUB = J
               SMIN = D( J )
            END IF
  180    CONTINUE
         IF( ISUB.NE.N+1-I ) THEN
*
*           Swap singular values and vectors
*
            D( ISUB ) = D( N+1-I )
            D( N+1-I ) = SMIN
            IF( NCVT.GT.0 )
     $         CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
     $                     LDVT )
            IF( NRU.GT.0 )
     $         CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
            IF( NCC.GT.0 )
     $         CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
         END IF
  190 CONTINUE
      GO TO 220
*
*     Maximum number of iterations exceeded, failure to converge
*
  200 CONTINUE
      INFO = 0
      DO 210 I = 1, N - 1
         IF( E( I ).NE.ZERO )
     $      INFO = INFO + 1
  210 CONTINUE
  220 CONTINUE
      RETURN
*
*     End of DBDSQR
*
      END


C     PROGRAM No. 15: SUDDEN ACCELERATION OF A FLAT PLATE (LUMPED VORTEX)
C     ----------------------------------------------------------------
C     TRANSIENT AERODYNAMIC OF A FLAT PLATE REPRESENTED BY A SINGLE LUMPED
C     VORTEX ELEMENT (PREPARED AS A SOLUTION OF HOMEWORK PROBLEMS BY JOE
C     KATZ, 1987).
      DIMENSION VORTIC(50,3),UW(50,2)
C                   VORTIC(IT,X,Z,GAMMA)
      COMMON/NO1/ IT,VORTIC

      NSTEP=20
      PAY=3.141592654
      RO=1.
      UT=50.0
      C=1.0
      ALFA1=5.0
      ALFA=ALFA1*PAY/180.0
      SN=SIN(ALFA)
      CS=COS(ALFA)
      DT=C/UT/4.0
      T=-DT
      DXW=0.3*UT*DT
      WRITE(6,11)
C
C     PROGRAM START
C
      DO 100 IT=1,NSTEP
      T=T+DT
C     PATH OF ORIGIN (SX,SZ)
      SX=-UT*T
      SZ=0.0
C     SHEDDING OF WAKE POINTS
      VORTIC(IT,1)=(C+DXW)*CS+SX
      VORTIC(IT,2)=-(C+DXW)*SN+SZ
C
C     CALCULATE MOMENTARY VORTEX STRENGTH OF WING AND WAKE VORTICES
C
      A=-1/(PAY*C)
      B=1/(2.0*PAY*(C/4.0+DXW))
      RHS2=0.0
      WWAKE=0.0
      IF(IT.EQ.1) GOTO 2
      IT1=IT-1

C     CALCULATE WAKE INFLUENCE
      XX1=0.75*C*CS+SX
      ZZ1=-0.75*C*SN+SZ
      CALL DWASH(XX1,ZZ1,1,IT1,U,W)
      WWAKE=U*SN+W*CS

C     CALCULATION OF RHS
      DO 1 I=1,IT1
 1    RHS2=RHS2-VORTIC(I,3)
 2    CONTINUE
      RHS1=-UT*SN-WWAKE

C     SOLUTION (BASED ON ALGEBRAIC SOLUTION OF TWO EQUATIONS FOR GAMMAT
C     AND THE LATEST WAKE VORTEX STRENGTH VORTIC(IT,3).
      VORTIC(IT,3)=1/(B/A-1.0)*(RHS1/A-RHS2)
      GAMMAT=RHS2-VORTIC(IT,3)
C
C     WAKE ROLLUP
C
      IF(IT.LT.1) GOTO 5
      DO 3 I=1,IT
      XX1=0.25*C*CS+SX
      ZZ1=-0.25*C*SN+SZ
      CALL VOR2D(VORTIC(I,1),VORTIC(I,2),XX1,ZZ1,GAMMAT,U,W)
      CALL DWASH(VORTIC(I,1),VORTIC(I,2),1,IT,U1,W1)
      U=U+U1
      W=W+W1
      UW(I,1)=VORTIC(I,1)+U*DT
      UW(I,2)=VORTIC(I,2)+W*DT
 3    CONTINUE
      DO 4 I=1,IT
      VORTIC(I,1)=UW(I,1)
 4    VORTIC(I,2)=UW(I,2)
 5    CONTINUE
C
C     AERODYNAMIC LOADS
C
      IF(IT.EQ.1) GAMAT1=0.0
      QUE=0.5*RO*UT*UT
      DGAMDT=(GAMMAT-GAMAT1)/DT
      GAMAT1=GAMMAT
C     CALCULATE WAKE INDUCED DOWNWASH
      XX1=0.75*C*CS+SX
      ZZ1=-0.75*C*SN+SZ
      CALL DWASH(XX1,ZZ1,1,IT,U,W)
      WW=U*SN+W*CS
      L=RO*(UT*GAMMAT+DGAMDT*C)
      D=RO*(-WW*GAMMAT+DGAMDT*C*SN)
      CL=L/QUE/C
      CD=D/QUE/C
C
C     OUTPUT
C
      CLT=CL/(2.0*PAY*SN)
      GAM1=GAMMAT/(PAY*UT*C*SN)
      SX1=SX-UT*DT
      WRITE(6,10) IT,SX1,CD,CL,GAM1,CLT
C
 100  CONTINUE
 10   FORMAT(I3,10F7.3)
 11   FORMAT(' SUDDEN ACCELARATION OF A FLAT PLATE',/,38('='),//,
     *' IT',4X,'SX',5X,'CD',5X,'CL',3X,'GAMMAT',3X,'CLT')
      STOP
      END
C
C
      SUBROUTINE DWASH(X,Z,I1,I2,U,W)
C     CALCULATES DOWNWASH INDUCED BY IT-1 WAKE VORTICES
      DIMENSION VORTIC(50,3)
      COMMON/NO1/ IT,VORTIC
      U=0.0
      W=0.0
      DO 1 I=I1,I2
      CALL VOR2D(X,Z,VORTIC(I,1),VORTIC(I,2),VORTIC(I,3),U1,W1)
      U=U+U1
      W=W+W1
 1    CONTINUE
      RETURN
      END
C
      SUBROUTINE VOR2D(X,Z,X1,Z1,GAMMA,U,W)
C     CALCULATES INFLUENCE OF VORTEX AT (X1,Z1)
      PAY=3.141592654
      U=0.0
      W=0.0
      RX=X-X1
      RZ=Z-Z1
      R=SQRT(RX**2+RZ**2)
      IF(R.LT.0.001) GOTO 1
      V=0.5/PAY*GAMMA/R
      U=V*(RZ/R)
      W=V*(-RX/R)
 1    CONTINUE
      RETURN
      END


! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

module parBeam

! This module is used to determine how the electron beam
! macroparticles in Puffin are spread across MPI processes.

use paratype
use typesandconstants
use globals

implicit none

contains

  SUBROUTINE splitBeam(N, globLen, numproc, rank, &
                      locN, local_start, local_end)

! Get local beam macroparticle number
! and start and end points in z2.
!
!           ARGUMENTS

    INTEGER(KIND=IP), INTENT(IN) :: N, numproc, rank
    REAL(KIND=WP), INTENT(IN) :: globLen

    INTEGER(KIND=IP), INTENT(OUT) :: locN
    REAL(KIND=WP), INTENT(OUT) :: local_start, local_end

!          LOCAL ARGS

    REAL(KIND=WP) :: frac, OneElmLength, upperLength, lowerLength
    INTEGER(KIND=IP) :: lowern, highern, remainder

    frac = REAL(N)/REAL(numproc)
    lowern = FLOOR(frac)
    highern = CEILING(frac)
    remainder = MOD(N,numproc)

    IF (remainder==0) THEN
       locN = lowern
    ELSE
       IF (rank < remainder) THEN
          locN = highern
       ELSE
          locN = lowern
       ENDIF
    ENDIF

!     Calculate the distance covered by one element of the grid in z2

    OneElmLength = globLen/N

!     Calculate the local length of the electron pulse a local process
!     will hold, in both the lower and upper case.

    lowerLength = lowern*OneElmLength
    upperLength = highern*OneElmLength

!     Calculate local start and end values.

    IF (rank >= remainder) THEN
       local_start = (upperLength*remainder) + &
            ((rank-remainder)*lowerLength)
       local_end = (upperLength*remainder) +&
            (((rank+1)-remainder)*lowerLength)
    ELSE
       local_start = rank*upperLength
       local_end = (rank+1)*upperLength
    ENDIF

  END SUBROUTINE splitBeam

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE splitBeams(iNMP,samLenE,nBeams,numproc,rank,&
                      iNumLocalElectrons,totalmps_b)

  IMPLICIT NONE

!                   ARGUMENTS

  INTEGER(KIND=IP), INTENT(IN) :: iNMP(:,:)
  REAL(KIND=WP), INTENT(IN) :: samLenE(:,:)
  INTEGER(KIND=IP), INTENT(IN) :: nBeams
  INTEGER, INTENT(IN) :: numproc, rank
  INTEGER(KIND=IP), INTENT(INOUT) :: iNumLocalElectrons(:,:)
  INTEGER(KIND=IPL), INTENT(INOUT) :: totalmps_b(:)

!                   LOCAL ARGS

  REAL(KIND=WP) :: local_start, local_end
  INTEGER(KIND=IP) :: ind

!     Split electron macroparticles across z2

  iNumLocalElectrons(:,iX_CG) = iNMP(:,iX_CG)
  iNumLocalElectrons(:,iY_CG) = iNMP(:,iY_CG)
  iNumLocalElectrons(:,iPX_CG) = iNMP(:,iPX_CG)
  iNumLocalElectrons(:,iPY_CG) = iNMP(:,iPY_CG)
  iNumLocalElectrons(:,iGam_CG) = iNMP(:,iGam_CG)

  DO ind = 1, nBeams

    CALL splitBeam(iNMP(ind,iZ2_CG), samLenE(ind,iZ2_CG), numproc, rank, &
                   iNumLocalElectrons(ind,iZ2_CG), local_start, local_end)

!             Total no of MPs in this beam

    if (qEquiXY_G) then

      totalmps_b(ind) = PRODUCT(INT(iNumLocalElectrons(ind,:),KIND=IPL))

    else

      totalmps_b(ind) = INT(iNumLocalElectrons(ind,iZ2_CG) * &
                               nseqparts_G,KIND=IPL)

    end if

  end do

end subroutine splitBeams

subroutine divMPs(ndpts, numproc, rank, &
                  locN, local_start, local_end)

! Get local number of nodes and start and global
! indices of start and end points.
!
!           ARGUMENTS

  integer(kind=ip), intent(in) :: ndpts, numproc, rank

  integer(kind=ip), intent(out) :: locN
  integer(kind=ip), intent(out) :: local_start, local_end

!          LOCAL ARGS

  real(kind=wp) :: frac
  integer(kind=ip) :: lowern, highern, remainder

  frac = REAL(ndpts,kind=wp)/REAL(numproc,kind=wp)
  lowern = FLOOR(frac)
  highern = CEILING(frac)
  remainder = MOD(ndpts,numproc)

  IF (remainder==0) THEN
     locN = lowern
  ELSE
     IF (rank < remainder) THEN
        locN = highern
     ELSE
        locN = lowern
     ENDIF
  ENDIF

!     Calculate local start and end values.

  IF (rank >= remainder) THEN

    local_start = (remainder*highern) + ((rank-remainder) * lowern) + 1
    local_end = local_start + locN - 1

  ELSE

    local_start = rank*locN + 1
    local_end = local_start + locN - 1

  ENDIF

end subroutine divMPs

end module parBeam


      INTEGER N,m
      PARAMETER(N=32,m=100000) ! N = Number od differential equation, m = Number of divisions between x1 and x2
      INTEGER:: i
!	  complex::al,be

	  REAL h,x,y(N),dydx(N),yout(N)
      EXTERNAL derivs
      open(10,file='e:\1\JC_Model_Rho_Mixed.txt')  ! Output program results
      ! -------------- initial conditons --------------
      x1=0.0                      ! x1 = t1
	  x2=10                       ! x2 = t2
      y(1)=  0.25
      y(2)=  0
      y(3)=  0
      y(4)=  0
      y(5)=  0
      y(6)=  0
      y(7)=  0
      y(8)=  0
      y(9)=  0
      y(10)= 0
      y(11)= 0.25
      y(12)= 0
      y(13)= 0
      y(14)= 0
      y(15)= 0
      y(16)= 0
      y(17)= 0
      y(18)= 0
      y(19)= 0
      y(20)= 0
      y(21)= 0.25
      y(22)= 0
      y(23)= 0
      y(24)= 0
      y(25)= 0
      y(26)= 0
      y(27)= 0
      y(28)= 0
      y(29)= 0
      y(30)= 0
      y(31)= 0.25
      y(32)= 0

	   x=x1
	   h=(x2-x1)/m                        ! Number of divisions
       do i=0,m-1
	      x=x1+i*h
          call derivs(x,y,dydx)
          call rk4(y,dydx,N,x,h,yout,derivs)
              x=x1+i*h
              trace_rho = y(1)+y(2)+y(11)+y(12)+y(21)+y(22)+y(31)+y(32)
          if (mod(i,10)==0) then
              write(10,'(48(f10.4,2x))')x,y(1),y(2),y(3),y(4),y(5),y(6)   ! (#(f10.4,2x)) == # -> number of outputs ; f10 -> serial number for output file
     &         ,y(7),y(8),y(9),y(10),y(11),y(12),y(13),y(14),y(15),y(16)
     &         ,y(17),y(18),y(19),y(20),y(21),y(22),y(23),y(24),y(25)
     &         ,y(26),y(27),y(28),y(29),y(30),y(31),y(32),trace_rho ! Computational values to create in the file a.txt
          end if
	      do j=1,n
	        y(j)=yout(j) !/sqrt((r11+r22))
	     end do
      end do

      END

      SUBROUTINE derivs(x,y,dydx)

      REAL x,y(*),dydx(*)

      ! --------------- initial values ---------------

	  wa=1      ! atomic frequency
	  wp=0.6      ! field frequency
	  g=0.8   ! coupling strength
      n_p = 20     ! number of photons

      ! ----------------- Equations ------------------

      Xm = n_p+1
      C = g*SQRT(Xm)

      ! ----------- Differential equations -----------

      dydx(1)=   0
      dydx(2)=   0
      dydx(3)=  -C*y(6)-wp*y(4)
      dydx(4)=  +C*y(5)+wp*y(3)
      dydx(5)=  -C*y(4)-wa*y(6)
      dydx(6)=  +C*y(3)+wa*y(5)
      dydx(7)=  -(wa+wp)*y(8)
      dydx(8)=  +(wa+wp)*y(7)
      dydx(9)=  +C*y(18)+wp*y(10)
      dydx(10)= -C*y(17)-wp*y(9)
      dydx(11)= +C*(-y(14)+y(20))
      dydx(12)= +C*(y(13)-y(19))
      dydx(13)= +C*(y(22)-y(12))-(wa-wp)*y(14)
      dydx(14)= -C*(y(21)-y(11))+(wa-wp)*y(13)
      dydx(15)= +C*y(24)-wa*y(16)
      dydx(16)= -C*y(23)+wa*y(15)
      dydx(17)= +C*y(10)+wa*y(18)
      dydx(18)= -C*y(9)-wa*y(17)
      dydx(19)= +C*(y(12)-y(22))-(-wa+wp)*y(20)
      dydx(20)= -C*(y(11)-y(21))+(-wa+wp)*y(19)
      dydx(21)= +C*(y(14)-y(20))
      dydx(22)= -C*(y(13)-y(19))
      dydx(23)= +C*y(16)-wp*y(24)
      dydx(24)= -C*y(15)+wp*y(23)
      dydx(25)= +(wa+wp)*y(26)
      dydx(26)= -(wa+wp)*y(25)
      dydx(27)= -C*y(30)+wa*y(28)
      dydx(28)= +C*y(29)-wa*y(27)
      dydx(29)= -C*y(28)+wp*y(30)
      dydx(30)= +C*y(27)-wp*y(29)
      dydx(31)=  0
      dydx(32)=  0

      return

      end

      ! ------------ Runge-Kutta Function ------------

      SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)
      INTEGER n,NMAX
      REAL h,x,dydx(n),y(n),yout(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
      INTEGER i
      REAL h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)
      hh=h*0.5
      h6=h/6.
	  x=0
      xh=x+hh
      do 11 i=1,n
        yt(i)=y(i)+hh*dydx(i)
11    continue
      call derivs(xh,yt,dyt)
      do 12 i=1,n
        yt(i)=y(i)+hh*dyt(i)
12    continue
      call derivs(xh,yt,dym)
      do 13 i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
13    continue
      call derivs(x+h,yt,dyt)
      do 14 i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))

14    continue
      return
      END


      subroutine matvec(x,y)
      complex(8) :: x(4), y(4)
      !call zcopy(4,x,1,y,1)
      y(:) = x(:)
      end subroutine matvec

      program main
      use explib
      integer i, n
      complex(8) :: v(4), w(4)
      complex(8) :: zdotc, hij, ONE, ZERO
      real(8) :: tol
      external matvec
      ONE = (1d0,0d0)
      ZERO = (0d0, 0d0)
      do i = 1,4
        v(i) = (0d0, 1d0)
        w(i) = (0d0, 1d0)
      end do
      n = 4
      !hij = zdotc(n,v,1,w,1)
      !call zgemm('c','n',1,1,n,ONE,v,n,w,n,ZERO,hij,1)
      !print *, n
      !call temp()
      tol = 1e-8
      call zexp_mv(4,4,1d-2,v,w,tol,1d0,matvec)
      end program main


C++***************************************************************
C Program to compute the residual dispersion
C of Risley prisms (to correct atmospheric dispersion)
C Used for computing the angle of Risley prisms for the TBL speckle camera.
C
C JLP
C Version of 10-03-91
C--***************************************************************
	PROGRAM RISLEY
	PARAMETER (IDIM=1024)
	REAL*4 LAMBDA(IDIM),AD(IDIM)
	REAL*4 INDEX1(IDIM),INDEX2(IDIM),RESIDUAL(IDIM)
        REAL*4 PP,FF,TT,ZD,BETA1,BETA2,CLAMBDA,DLAMBDA
	CHARACTER OUTFILE*40,BUFFER*90

	WRITE(6,35)
35	FORMAT(' Program RISLEY to compute Risley prisms',
     1  ' for the T2M speckle camera',/)

	WRITE(6,36)
36	FORMAT(' Enter P (mm Hg, atm. pressure), F (mm, water vapor),',
     1	/,' T (degree C, temperature), Zenith angle (degrees) :')
	READ(5,*) PP,FF,TT,ZD

	WRITE(6,39)
39	FORMAT(' Enter roof angle of F4 and SK10 prisms: (degrees)')
	READ(5,*) BETA1,BETA2
	BETA1=BETA1*3.1415926/180.
	BETA2=BETA2*3.1415926/180.

	WRITE(6,40)
40	FORMAT(' Enter central lambda and delta lambda (nm):')
	READ(5,*) CLAMBDA,DLAMBDA
	CLAMBDA=CLAMBDA/1000.
	DLAMBDA=DLAMBDA/1000.

	WRITE(6,48)
48	FORMAT(' Enter crossing angle between the two sets of',
     1      ' prisms: (degrees)')
	READ(5,*) CROSS_ANGLE
	CANGLE=(CROSS_ANGLE/2.)*3.1415926/180.

C With 66 points, the step is 10 nm:
	NPTS=66
	STEP=(1-0.35)/FLOAT(NPTS-1)
C First Lambda in microns (for the formulae..)
	DO I=1,NPTS
	  LAMBDA(I)=0.35+STEP*FLOAT(I-1)
        END DO
        CALL INDEX_MAX4(LAMBDA,NPTS,CLAMBDA,KCENT)
	WORK1=CLAMBDA-DLAMBDA/2.
        CALL INDEX_MAX4(LAMBDA,NPTS,WORK1,K1)
	WORK2=CLAMBDA+DLAMBDA/2.
        CALL INDEX_MAX4(LAMBDA,NPTS,WORK2,K2)
        PRINT *,' K',KCENT,K1,K2

	WRITE(6,37)
37	FORMAT(' Output file:')
	READ(5,10) OUTFILE
10	FORMAT(A)

C Computing the indices of the prisms:
	CALL PRISM_INDEX(INDEX1,INDEX2,LAMBDA,NPTS,IDIM)
        IF(I.EQ.1234)THEN
	  OPEN(3,FILE='f4_sk10.dat',STATUS='UNKNOWN',ACCESS='SEQUENTIAL')
          DO I=1,NPTS
	    WRITE(3,65) LAMBDA(I),INDEX1(I),INDEX2(I)
65	    FORMAT(3(F8.6,2X))
          ENDDO
          CLOSE(3)
          PRINT *,' Output of the index file f4_sk10.dat (f4 and sk10)'
        ENDIF

C Computing the atmospheric dispersion in arcseconds:
	CALL ATM_REFRAC1(PP,FF,TT,ZD,LAMBDA,AD,NPTS,IDIM)

C Translating atm. dispersion:
	WORK1=AD(KCENT)
	DO I=1,NPTS
	  AD(I)=AD(I)-WORK1
        END DO

C Computing residual dispersion:
        RADTOSEC=180.*3600./3.1415926
	WORK3=2.*COS(CANGLE)*RADTOSEC/200.
        DO I=1,NPTS
	  WORK1=(INDEX1(I)-1.)*SIN(BETA1)
	  WORK2=(INDEX2(I)-1.)*SIN(BETA2)
C For the T2M speckle camera, the magnification factor is 200:
	  RESIDUAL(I)=AD(I)-(WORK1-WORK2)*WORK3
C	  IF(I.LT.20)THEN
C	    PRINT *,AD(I),WORK1,WORK2,RESIDUAL(I)
C	  ENDIF
        ENDDO

C Computing mean deviation and residual dispersion:
	WORK1=SQRT(WORK1)*(180./3.1415926)/200.
        WORK2=RESIDUAL(K2)-RESIDUAL(K1)
	WRITE(6,49) RESIDUAL(K2),WORK2
49	FORMAT(' Mean deviation of the beam at',
	1    ' central wavelength (degrees) ',
	1    G12.5,/,' Residual dispersion (arcsec) ',F10.5)

C Conversion to nm:
	WORK1=RESIDUAL(KCENT)
	DO I=1,NPTS
	  LAMBDA(I)=LAMBDA(I)*1000.
	  RESIDUAL(I)=RESIDUAL(I)-WORK1
        END DO

C Output of the data:
	OPEN(1,FILE=OUTFILE,STATUS='UNKNOWN',ACCESS='SEQUENTIAL')
	WRITE(6,45)
45	FORMAT(' Output of the full dispersion (atmos + prism)',
     1    ' in arcsec',/,' lambda, resid, dispers., F4, SK10')
	WRITE(BUFFER,41) LAMBDA(1),RESIDUAL(1),AD(1),INDEX1(1),INDEX2(1),
	1      PP,FF,TT,ZD
41	FORMAT(F8.2,4(1X,F7.4),5X,F8.2,1X,3(F5.1,1X))
	WRITE(1,10) BUFFER
	DO I=2,NPTS
	  WRITE(1,42) LAMBDA(I),RESIDUAL(I),AD(I),INDEX1(I),INDEX2(I)
42	  FORMAT(F8.2,4(1X,F7.4))
	END DO
	CLOSE(1)

	STOP
	END
C****************************************************************
C SK10 and F4
C****************************************************************
	SUBROUTINE PRISM_INDEX(INDEX1,INDEX2,LAMBDA,NPTS,IDIM)
	REAL*4 F4(6),SK10(6)
	REAL*4 LAMBDA(IDIM),INDEX1(IDIM),INDEX2(IDIM)
	DATA F4/2.54469,-8.5925665E-03,2.2583116E-02,
     1  7.3789910E-04,-9.5060668E-06,3.82577E-08/
	DATA SK10/2.588171,-9.3042171E-03,1.6075769E-02,
     1  2.2083748E-04,3.5467529E-06,2.6143582E-07/

	DO I=1,NPTS
	  Y2=LAMBDA(I)*LAMBDA(I)
	  YY=1./Y2
C Index:
	  INDEX1(I)=F4(1)+F4(2)*Y2+F4(3)*YY+F4(4)*YY*YY
     1  +F4(5)*YY*YY*YY+F4(6)*YY*YY*YY*YY
	  INDEX1(I)=SQRT(INDEX1(I))
	  INDEX2(I)=SK10(1)+SK10(2)*Y2+SK10(3)*YY+SK10(4)*YY*YY
     1  +SK10(5)*YY*YY*YY+SK10(6)*YY*YY*YY*YY
	  INDEX2(I)=SQRT(INDEX2(I))

	END DO

	RETURN
	END
C***************************************************************
C Routine to compute atmospheric refraction versus wavelength
C From Simon, W. 1966, A.J. 71,190
C--***************************************************************
	SUBROUTINE ATM_REFRAC1(PP,FF,TT,ZD,LAMBDA,AD,NPTS,IDIM)
	REAL*4 CC(15),LAMBDA(IDIM),AD(IDIM)
        REAL*4 PP,FF,TT,ZD,ZD_RAD,PI
        REAL*4 ZZ,Z2,Z3,Z4,SS,SQ,QQ,YY,Y2
	DATA CC/3.45020E-03,-3.34591E-04,-1.60149E-05,-1.54316,
     1	2.27095E-01,3.14759E-03,2.87409E-03,-2.92730E-04,
     1	-1.56673E-05,1.41299E-03,-2.22307E-04,-1.66610E-06,
     1	-3.34814E-05,5.33352E-06,3.52107E-08/
	DATA QQ/0.740568/

	WRITE(6,35)
35	FORMAT(' Computing atmospheric refraction',/,
     1	' From Simon, W. 1966, A.J. 71,190, h0=2811m, p0=547mm, T0=6deg')
C	PRINT *,' PP,FF,TT,ZD',PP,FF,TT,ZD

        PI = 3.14159265
        ZD_RAD = ZD*PI/180.0
	ZZ=TAN(ZD_RAD)
	Z2=ZZ*ZZ
	Z3=Z2*ZZ
	Z4=Z2*Z2

	SS=PP-0.148238*FF+(1.049-0.0157*TT)*PP*PP*1.E-06
	SS=SS/(720.883*(1.+0.003661*TT))
	SQ=SS/QQ

	DO I=1,NPTS
	  YY=1./(LAMBDA(I)*LAMBDA(I))
	  Y2=YY*YY
C Atmospheric dispersion in arcsec
C (From Simon, W. 1966, A.J. 71,190)
	  AD(I)=CC(1)+CC(2)*YY+CC(3)*Y2+CC(4)*ZZ+CC(5)*ZZ*YY
     1	+CC(6)*ZZ*Y2+CC(7)*Z2+CC(8)*Z2*YY+CC(9)*Z2*Y2
     1	+CC(10)*Z3+CC(11)*Z3*YY+CC(12)*Z3*Y2+CC(13)*Z4
     1	+CC(14)*Z4*YY+CC(15)*Z4*Y2
	  AD(I)=AD(I)*SQ
	END DO

	RETURN
	END
C***************************************************************
C Routine to compute atmospheric refraction versus wavelength
C From Simon, W. 1966, A.J. 71,190
C--***************************************************************
	SUBROUTINE ATM_REFRAC2(PP,FF,TT,ZD,LAMBDA,AD,NPTS,IDIM)
	REAL*4 CC(15),LAMBDA(IDIM),AD(IDIM)
        REAL*4 PP,FF,TT,ZD,ZD_RAD,PI
        REAL*4 ZZ,Z2,Z3,Z4,SS,SQ,QQ,YY,Y2
	DATA CC/3.45020E-03,-3.34591E-04,-1.60149E-05,-1.54316,
     1	2.27095E-01,3.14759E-03,2.87409E-03,-2.92730E-04,
     1	-1.56673E-05,1.41299E-03,-2.22307E-04,-1.66610E-06,
     1	-3.34814E-05,5.33352E-06,3.52107E-08/
	DATA QQ/0.740568/

	WRITE(6,35)
35	FORMAT(' Computing atmospheric refraction',/,
     1	' From Simon, W. 1966, A.J. 71,190, h0=2811m, p0=547mm, T0=6deg')
C	PRINT *,' PP,FF,TT,ZD',PP,FF,TT,ZD

        PI = 3.14159265
        ZD_RAD = ZD*PI/180.0
	ZZ=TAN(ZD_RAD)
	Z2=ZZ*ZZ
	Z3=Z2*ZZ
	Z4=Z2*Z2

	SS=PP-0.148238*FF+(1.049-0.0157*TT)*PP*PP*1.E-06
	SS=SS/(720.883*(1.+0.003661*TT))
	SQ=SS/QQ

	DO I=1,NPTS
	  YY=1./(LAMBDA(I)*LAMBDA(I))
	  Y2=YY*YY
C Atmospheric dispersion in arcsec
C (From Simon, W. 1966, A.J. 71,190)
	  AD(I)=CC(1)+CC(2)*YY+CC(3)*Y2+CC(4)*ZZ+CC(5)*ZZ*YY
     1	+CC(6)*ZZ*Y2+CC(7)*Z2+CC(8)*Z2*YY+CC(9)*Z2*Y2
     1	+CC(10)*Z3+CC(11)*Z3*YY+CC(12)*Z3*Y2+CC(13)*Z4
     1	+CC(14)*Z4*YY+CC(15)*Z4*Y2
	  AD(I)=AD(I)*SQ
	END DO

	RETURN
	END


// Developed by Simen Haugo.
// See LICENSE.txt for copyright and licensing details (standard MIT License).

float model(vec3 p) {
    float d = fSphere(p, 0.5);

    // grooves
    vec3 q = p;
    float t = q.y + 0.5;
    q.xz = pOpRotate(q.xz, -smoothstep(0.0,0.5,0.5*t)*0.7);
    float a = atan(q.z, q.x);
    d -= 0.03*sin(14.0*a);
    d *= 0.5; // Lipschitz factor

    // Top
    p.y -= 0.5;
    d = fOpUnionSoft(d, fCylinder(p, 0.2, 1.0), 0.3);
    p.y -= 1.0;
    d = fOpUnionSoft(d, fCylinder(p, 0.3, 0.01), 0.1);
    float inside = fCylinder(p, 0.18, 1.2);
    p.y += 1.5;
    inside = fOpUnionSoft(inside, fSphere(p, 0.4), 0.3);
    d = max(d, -inside);

    return d;
}


! { dg-do run { xfail powerpc*-apple-darwin* powerpc*-*-linux* } }
! Test XFAILed on these platforms because the system's printf() lacks
! proper support for denormalized long doubles. See PR24685
! { dg-require-effective-target fortran_large_real }
! PR libfortran/24685
program large_real_kind_form_io_2
  ! This should be 10 or 16 on systems that support kind=10 or kind=16
  integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1)
  real(kind=k) :: a,b(2), c
  character(len=180) :: tmp

  b(:) = huge(0.0_k)
  write (tmp, *) b
  read (tmp, *) a, c
  if (a /= b(1)) STOP 1
  if (c /= b(2)) STOP 2

  b(:) = -huge(0.0_k)
  write (tmp, *) b
  read (tmp, *) a, c
  if (a /= b(1)) STOP 3
  if (c /= b(2)) STOP 4

  b(:) = nearest(tiny(0.0_k),1.0_k)
  write (tmp, *) b
  read (tmp, *) a, c
  if (a /= b(1)) STOP 5
  if (c /= b(2)) STOP 6

  b(:) = nearest(-tiny(0.0_k),-1.0_k)
  write (tmp, *) b
  read (tmp, *) a, c
  if (a /= b(1)) STOP 7
  if (c /= b(2)) STOP 8
end program large_real_kind_form_io_2


program cubic_lattice
    implicit none
    integer :: i, j, k, nx=20, ny=10, nz=10
    real*8 :: x, y, z
    open(23, file='cubic.xyz', action='write')
    do i=1,nx
        do j=1,ny
            do k=1,10
                x=dfloat(i)-1.0d0
                y=2.0d0*dfloat(j)-1.0d0
                z=2.0d0*dfloat(k)-1.0d0
                write(23,*) x, y, z
            end do
        end do
    end do
    close(23)
end program cubic_lattice


MODULE FUN_xyNORMSQRD
!!#### PURPOSE
!! Compute the square of the normalization factor for a
!! vector in R^2.

!!#### METHOD
!! Sum of the squares of x and y components.

!!#### DEPENDENCIES
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyNORMSQRD_V
 MODULE PROCEDURE xyNORMSQRD_V_Rsp
 MODULE PROCEDURE xyNORMSQRD_V_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyNORMSQRD_V

CONTAINS

PURE FUNCTION xyNORMSQRD_V_Rsp( V ) RESULT(NORMSQRD)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyNORMSQRD_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyNORMSQRD_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyNORMSQRD_V_Rdp( V ) RESULT(NORMSQRD)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyNORMSQRD_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyNORMSQRD_V.f90.bdy"
!!--end--
END FUNCTION

END MODULE


SUBROUTINE ives(n)

! Generate all permutations of the N elements in array IX.
! This is algorithm 4a (Alternate Ives) from page 149 of:-
!   Sedgewick, R. Permutation generation methods, ACM Computing Surveys,
!                 9, 137-164, 1977.

! N.B. The user's subroutine for doing something with each new permutation
!      is called from this subroutine.

IMPLICIT NONE
INTEGER, INTENT(IN) :: n

! Local variables
INTEGER  :: ix(n), INDEX(15), i, itemp, j, np1mi

DO i = 1,n
  INDEX(i) = 1
END DO
i = 1

!     Insert initial call to user's process here.

DO
  j = INDEX(i)
  np1mi = n+1-i
  IF(j >= np1mi) GO TO 50
  IF(i == 2*(i/2)) GO TO 30
  itemp = ix(j)
  ix(j) = ix(j+1)
  ix(j+1) = itemp
  GO TO 40

  30 itemp = ix(i)
  ix(i) = ix(np1mi)
  ix(np1mi) = itemp

  40 INDEX(i) = j+1
  i = 1

  !     Insert main call to user's process here.

  CYCLE
  50 INDEX(i) = 1
  i = i+1
  IF(i > n) EXIT
END DO

RETURN
END SUBROUTINE ives


module test_cases
	use iso_c_binding
	use fruit
	use constants
	implicit none

contains

	subroutine factorial_positive
		call assert_equals(1d0, factorial(1), 'factorial(1) failed')
		call assert_equals(120d0, factorial(5), 'factorial(5) failed')
		call assert_equals(3.55687428096D+14, factorial(17), 'factorial(17) failed')
	end subroutine factorial_positive

	subroutine factorial_zero
		call assert_equals(1d0, factorial(0), 'factorial_zero failed')
	end subroutine factorial_zero

	subroutine factorial_negative
		call assert_equals(1d0, factorial(-5), 'factorial_negative failed')
	end subroutine factorial_negative

	subroutine time_check
		character(len=100) 	:: result
		logical(sint)  		:: check
		result = trim(adjustl(format_time(14985.781d0)))
		! should give 4h: 9m:45s
		check =  '4h: 9m:45s' .eq. result
		write(*, *) result
		call assert_true(check, 'time_check failed')
	end subroutine time_check

end module test_cases

program constants_test
  use fruit
  use test_cases

  implicit none

  logical(sint) :: ok

  call init_fruit

  ! call all tests
  call factorial_positive
  call factorial_zero
  call factorial_negative
  call time_check

  call fruit_summary
  call fruit_finalize

  call is_all_successful(ok)
  if (.not. ok) call exit(1)

end program constants_test


! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! .                                                                       .
! .                            S T A P 9 0                                .
! .                                                                       .
! .     AN IN-CORE SOLUTION STATIC ANALYSIS PROGRAM IN FORTRAN 90         .
! .     Adapted from STAP (KJ Bath, FORTRAN IV) for teaching purpose      .
! .                                                                       .
! .     Xiong Zhang, (2013)                                               .
! .     Computational Dynamics Group, School of Aerospace                 .
! .     Tsinghua Univerity                                                .
! .                                                                       .
! . . . . . . . . . . . . . .  . . .  . . . . . . . . . . . . . . . . . . .

SUBROUTINE COLHT (MHT,ND,LM)
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! .                                                                   .
! .   To calculate column heights                                     .
! .                                                                   .
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

  USE GLOBALS, ONLY : NEQ
  IMPLICIT NONE
  INTEGER :: ND, LM(ND),MHT(NEQ)
  INTEGER :: I, LS, II, ME

  LS=HUGE(1)   ! The largest integer number

  DO I=1,ND
     IF (LM(I) .NE. 0) THEN
        IF (LM(I)-LS .LT. 0) LS=LM(I)
     END IF
  END DO

  DO I=1,ND
     II=LM(I)
     IF (II.NE.0) THEN
        ME=II - LS
        IF (ME.GT.MHT(II)) MHT(II)=ME
     END IF
  END DO

  RETURN
END SUBROUTINE COLHT

SUBROUTINE ADDRES (MAXA,MHT)
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! .                                                                   .
! .   To calculate addresses of diagonal elements in banded           .
! .   matrix whose column heights are known                           .
! .                                                                   .
! .   MHT  = Active column heights                                    .
! .   MAXA = Addresses of diagonal elements                           .
! .                                                                   .
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

  USE GLOBALS, ONLY : NEQ, MK, NWK

  IMPLICIT NONE
  INTEGER :: MAXA(NEQ+1),MHT(NEQ)
  INTEGER :: NN, I

! Clear array maxa

  NN=NEQ + 1
  DO I=1,NN
     MAXA(I)=0.0
  END DO

  MAXA(1)=1
  MAXA(2)=2
  MK=0
  IF (NEQ.GT.1) THEN
     DO I=2,NEQ
        IF (MHT(I).GT.MK) MK=MHT(I)
        MAXA(I+1)=MAXA(I) + MHT(I) + 1
     END DO
  END IF
  MK=MK + 1
  NWK=MAXA(NEQ+1) - MAXA(1)

  RETURN
END SUBROUTINE ADDRES

SUBROUTINE ASSEM (AA)
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! .                                                                   .
! .   To call element subroutines for assemblage of the               .
! .   structure stiffness matrix                                      .
! .                                                                   .
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

  USE GLOBALS, ONLY : IELMNT, NUMEG, MIDEST, NPAR

  IMPLICIT NONE
  REAL :: AA(*)
  INTEGER :: N, I

  REWIND IELMNT
  DO N=1,NUMEG
     READ (IELMNT) MIDEST,NPAR,(AA(I),I=1,MIDEST)
     CALL ELEMNT
  END DO

  RETURN
END SUBROUTINE ASSEM

SUBROUTINE ADDBAN (A,MAXA,S,LM,ND)
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! .                                                                   .
! .   To assemble element stiffness into compacted global stiffness   .
! .                                                                   .
! .      A = GLOBAL STIFFNESS (1D skyline storage)                    .
! .      S = ELEMENT STIFFNESS                                        .
! .      ND = DEGREES OF FREEDOM IN ELEMENT STIFFNESS                 .
! .                                                                   .
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  USE GLOBALS, ONLY : NWK, NEQ
  IMPLICIT NONE
  REAL(8) :: A(NWK),S(ND,ND)
  INTEGER :: MAXA(NEQ+1),LM(ND)
  INTEGER :: ND, I, J, II, JJ, KK

  DO J=1,ND
     JJ=LM(J)
     IF (JJ .GT. 0) THEN
        DO I=1,J
           II=LM(I)
           IF (II .GT. 0) THEN
              IF (JJ .GE. II) THEN
                 KK= MAXA(JJ) + JJ - II
              ELSE
                 KK= MAXA(II) + II - JJ
              END IF
              A(KK)=A(KK) + S(I,J)
           END IF
        END DO
     END IF
  END DO

  RETURN
    END SUBROUTINE ADDBAN

SUBROUTINE COLSOL (A,V,MAXA,NN,NWK,NNM,KKK)
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! .                                                                   .
! .   To solve finite element static equilibrium equations in         .
! .   core, using compacted storage and column reduction scheme       .
! .                                                                   .
! .  - - Input variables - -                                          .
! .        A(NWK)    = Stiffness matrix stored in compacted form      .
! .        V(NN)     = Right-hand-side load vector                    .
! .        MAXA(NNM) = Vector containing addresses of diagonal        .
! .                    elements of stiffness matrix in a              .
! .        NN        = Number of equations                            .
! .        NWK       = Number of elements below skyline of matrix     .
! .        NNM       = NN + 1                                         .
! .        KKK       = Input flag                                     .
! .            EQ. 1   Triangularization of stiffness matrix          .
! .            EQ. 2   Reduction and back-substitution of load vector .
! .        IOUT      = UNIT used for output                           .
! .                                                                   .
! .  - - OUTPUT - -                                                   .
! .        A(NWK)    = D and L - Factors of stiffness matrix          .
! .        V(NN)     = Displacement vector                            .
! .                                                                   .
! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

  USE GLOBALS, ONLY : IOUT

  IMPLICIT NONE
  INTEGER :: MAXA(NNM),NN,NWK,NNM,KKK
  REAL(8) :: A(NWK),V(NN),C,B
  INTEGER :: N,K,KN,KL,KU,KH,IC,KLT,KI,J,ND,KK,L
  INTEGER :: MIN0

! Perform L*D*L(T) factorization of stiffness matrix

  IF (KKK == 1) THEN

      DO N=1,NN
         KN=MAXA(N)
         KL=KN + 1
         KU=MAXA(N+1) - 1
         KH=KU - KL

         IF (KH > 0) THEN
             K=N - KH
             IC=0
             KLT=KU
             DO J=1,KH
                IC=IC + 1
                KLT=KLT - 1
                KI=MAXA(K)
                ND=MAXA(K+1) - KI - 1
                IF (ND .GT. 0) THEN
                   KK=MIN0(IC,ND)
                   C=0.
                   DO L=1,KK
                      C=C + A(KI+L)*A(KLT+L)
                   END DO
                   A(KLT)=A(KLT) - C
                END IF
                K=K + 1
             END DO
         ENDIF

         IF (KH >= 0) THEN
             K=N
             B=0.
             DO KK=KL,KU
                K=K - 1
                KI=MAXA(K)
                C=A(KK)/A(KI)
                B=B + C*A(KK)
                A(KK)=C
             END DO
             A(KN)=A(KN) - B
         ENDIF

         IF (A(KN) .LE. 0) THEN
            WRITE (IOUT,"(//' STOP - STIFFNESS MATRIX NOT POSITIVE DEFINITE',//,  &
                            ' NONPOSITIVE PIVOT FOR EQUATION ',I8,//,' PIVOT = ',E20.12 )") N,A(KN)
            STOP
         END IF
      END DO

  ELSE IF (KKK == 2) THEN

! REDUCE RIGHT-HAND-SIDE LOAD VECTOR

       DO N=1,NN
         KL=MAXA(N) + 1
         KU=MAXA(N+1) - 1
         IF (KU-KL .GE. 0) THEN
            !K=N
            !C=0.
            !DO KK=KL,KU
            !   K=K - 1
            !   C=C + A(KK)*V(K)
            !END DO
            C = dot_product(A(KL:KU),V(N-1:N-(KU-KL)-1:-1))
            V(N)=V(N) - C
         END IF
      END DO

! BACK-SUBSTITUTE

      DO N=1,NN
         K=MAXA(N)
         V(N)=V(N)/A(K)
      END DO

      IF (NN.EQ.1) RETURN

      N=NN
      DO L=2,NN
         KL=MAXA(N) + 1
         KU=MAXA(N+1) - 1
         IF (KU-KL .GE. 0) THEN
            K=N
            DO KK=KL,KU
               K=K - 1
               V(K)=V(K) - A(KK)*V(N)
            END DO
         END IF
         N=N - 1
      END DO
  END IF

END SUBROUTINE COLSOL


SUBROUTINE tridag_ser(a,b,c,r,u)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY : assert_eq,nrerror
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
  REAL(SP), DIMENSION(:), INTENT(OUT) :: u
  REAL(SP), DIMENSION(size(b)) :: gam
  INTEGER(I4) :: n,j
  REAL(SP) :: bet
  n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_ser')
  bet=b(1)
  if (bet == 0.0) call nrerror('tridag_ser: Error at code stage 1')
  u(1)=r(1)/bet
  do j=2,n
     gam(j)=c(j-1)/bet
     bet=b(j)-a(j-1)*gam(j)
     if (bet == 0.0) &
          call nrerror('tridag_ser: Error at code stage 2')
     u(j)=(r(j)-a(j-1)*u(j-1))/bet
  end do
  do j=n-1,1,-1
     u(j)=u(j)-gam(j+1)*u(j+1)
  end do
END SUBROUTINE tridag_ser

RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : tridag_ser
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
  REAL(SP), DIMENSION(:), INTENT(OUT) :: u
  INTEGER(I4), PARAMETER :: NPAR_TRIDAG=4
  INTEGER(I4) :: n,n2,nm,nx
  REAL(SP), DIMENSION(size(b)/2) :: y,q,piva
  REAL(SP), DIMENSION(size(b)/2-1) :: x,z
  REAL(SP), DIMENSION(size(a)/2) :: pivc
  n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_par')
  if (n < NPAR_TRIDAG) then
     call tridag_ser(a,b,c,r,u)
  else
     if (maxval(abs(b(1:n))) == 0.0) &
          call nrerror('tridag_par: possible singular matrix')
     n2=size(y)
     nm=size(pivc)
     nx=size(x)
     piva = a(1:n-1:2)/b(1:n-1:2)
     pivc = c(2:n-1:2)/b(3:n:2)
     y(1:nm) = b(2:n-1:2)-piva(1:nm)*c(1:n-2:2)-pivc*a(2:n-1:2)
     q(1:nm) = r(2:n-1:2)-piva(1:nm)*r(1:n-2:2)-pivc*r(3:n:2)
     if (nm < n2) then
        y(n2) = b(n)-piva(n2)*c(n-1)
        q(n2) = r(n)-piva(n2)*r(n-1)
     end if
     x = -piva(2:n2)*a(2:n-2:2)
     z = -pivc(1:nx)*c(3:n-1:2)
     call tridag_par(x,y,z,q,u(2:n:2))
     u(1) = (r(1)-c(1)*u(2))/b(1)
     u(3:n-1:2) = (r(3:n-1:2)-a(2:n-2:2)*u(2:n-2:2) &
          -c(3:n-1:2)*u(4:n:2))/b(3:n-1:2)
     if (nm == n2) u(n)=(r(n)-a(n-1)*u(n-1))/b(n)
  end if
END SUBROUTINE tridag_par

SUBROUTINE dtridag_ser(a,b,c,r,u)
  USE mo_kind, only: dp, i4
  USE mo_nrutil, ONLY : assert_eq,nrerror
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: a,b,c,r
  REAL(DP), DIMENSION(:), INTENT(OUT) :: u
  REAL(DP), DIMENSION(size(b)) :: gam
  INTEGER(I4) :: n,j
  REAL(DP) :: bet
  n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'dtridag_ser')
  bet=b(1)
  if (bet == 0.0_dp) call nrerror('dtridag_ser: Error at code stage 1')
  u(1)=r(1)/bet
  do j=2,n
     gam(j)=c(j-1)/bet
     bet=b(j)-a(j-1)*gam(j)
     if (bet == 0.0_dp) &
          call nrerror('tridag_ser: Error at code stage 2')
     u(j)=(r(j)-a(j-1)*u(j-1))/bet
  end do
  do j=n-1,1,-1
     u(j)=u(j)-gam(j+1)*u(j+1)
  end do
END SUBROUTINE dtridag_ser

RECURSIVE SUBROUTINE dtridag_par(a,b,c,r,u)
  USE mo_kind, only: dp, i4
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : dtridag_ser
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: a,b,c,r
  REAL(DP), DIMENSION(:), INTENT(OUT) :: u
  INTEGER(I4), PARAMETER :: NPAR_TRIDAG=4
  INTEGER(I4) :: n,n2,nm,nx
  REAL(DP), DIMENSION(size(b)/2) :: y,q,piva
  REAL(DP), DIMENSION(size(b)/2-1) :: x,z
  REAL(DP), DIMENSION(size(a)/2) :: pivc
  n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'dtridag_par')
  if (n < NPAR_TRIDAG) then
     call dtridag_ser(a,b,c,r,u)
  else
     if (maxval(abs(b(1:n))) == 0.0_dp) &
          call nrerror('dtridag_par: possible singular matrix')
     n2=size(y)
     nm=size(pivc)
     nx=size(x)
     piva = a(1:n-1:2)/b(1:n-1:2)
     pivc = c(2:n-1:2)/b(3:n:2)
     y(1:nm) = b(2:n-1:2)-piva(1:nm)*c(1:n-2:2)-pivc*a(2:n-1:2)
     q(1:nm) = r(2:n-1:2)-piva(1:nm)*r(1:n-2:2)-pivc*r(3:n:2)
     if (nm < n2) then
        y(n2) = b(n)-piva(n2)*c(n-1)
        q(n2) = r(n)-piva(n2)*r(n-1)
     end if
     x = -piva(2:n2)*a(2:n-2:2)
     z = -pivc(1:nx)*c(3:n-1:2)
     call dtridag_par(x,y,z,q,u(2:n:2))
     u(1) = (r(1)-c(1)*u(2))/b(1)
     u(3:n-1:2) = (r(3:n-1:2)-a(2:n-2:2)*u(2:n-2:2) &
          -c(3:n-1:2)*u(4:n:2))/b(3:n-1:2)
     if (nm == n2) u(n)=(r(n)-a(n-1)*u(n-1))/b(n)
  end if
END SUBROUTINE dtridag_par


        subroutine bessel (xx, bj1)
c
c            bessel function calculation subroutine
c
      if (xx.le.3.0) then
        xx3 = xx/3.0
        aa = .5 - .56249 * xx3**2 + .21093 * xx3**4 - .03954 * xx3**6
        bb = .00443 * xx3**8 - .00031 * xx3**10 + .00001 * xx3**12
        bj1 = xx * (aa + bb)
      else
        x3x = 3.0/xx
        cc = .79788+1.56e-06 * x3x+ .01659 * x3x**2+ .00017 * x3x**3
        dd = -.00249 * x3x**4 + .00113 * x3x**5 - .0002 * x3x**6
        ff = cc + dd
        qq =xx-2.35619+0.12499* x3x+ .00005 * x3x**2- .00637 * x3x**3
        zz = .00074 * x3x**4 + .00079 * x3x**5 - .00029 * x3x**6
        tt = qq + zz
        bj1 = ff * cos(tt) / sqrt(xx)
      endif
      return
      end
c---------------------------------------------------------------


      subroutine pssev(ndim,ndata,nefn,w,rtol,atol,efn,evalu,evalu1)
c
c  computes eigenvalues for the discrete prolate spheroidal sequences
c  in efn by integration of the corresponding squared discrete prolate
c  spheroidal wavefunctions over the inner domain
c
c  ndim   - leading dimension of efn
c  ndata  - actual number of time points in each column of efn
c  nefn   - number of dpss (= number of columns in efn)
c  w      - the bandwidth (= time-bandwidth product/ndata)
c  rtol   - relative error tolerance for the integration. this is
c           roughly equal to the number of significant figures in the
c           result.
c  atol   - absolute error tolerance for the integration. this should
c           be set to 10**-n, where n is the number of significant figures
c           that can be be represented on the machine.
c  efn    - array containing the dpss
c  evalu  - vector of length nefn to contain the eigenvalues
c  evalu1 - vector of length nefn to contain (1-eigenvalues)
c
      implicit double precision (a-h,o-z)
      dimension efn(ndim,nefn),evalu(nefn),evalu1(nefn),result(8)
      external pssevf
c
c  calls dgqif,d1mach
c
      small=1000.*d1mach(4)
      do 20 k=1,nefn
        call dgqif(0.d0,w,result,kk,rtol,atol,7,icheck,pssevf,
     $             efn(1,k),ndata)
        if (icheck.ne.0) then
          write(*,*) ' dgqif did not converge for evalu(k) k =',k
        endif
        evalu(k)=2*result(kk)
c
c  calculate 1-eigenvalues, explicitly if necessary
c
        if((1.0d0-evalu(k)).le.small)then
c
c  break up 1-evalu calculation into reasonable pieces so dgqif can converge
c
          sum=0.d0
          do 10 rstep=w,.5d0,w
            rlow=rstep
            rup=min(rstep+w,.5d0)
            call dgqif(rlow,rup,result,kk,rtol,atol,7,icheck,pssevf,
     $                 efn(1,k),ndata)
            sum=sum+result(kk)
            if(icheck.ne.0)then
               write(*,*)' dgqif did not converge for 1-evalu(k) k =',k
            endif
   10     continue
          evalu1(k)=2.*sum
        else
          evalu1(k)=1.0d0-evalu(k)
        endif
   20 continue
      return
      end

c $Id$


      DIMENSION A(3,5),B(5,3),C(5,3)
      EQUIVALENCE (A,C)	!Occupy the same storage.
      DATA A/
     1     1, 2, 3, 4, 5,
     2     6, 7, 8, 9,10,
     3    11,12,13,14,15/	!Supplies values in storage order.

      WRITE (6,*) "Three rows of five values:"
      WRITE (6,1) A	!This shows values in storage order.
      WRITE (6,*) "...written as C(row,column):"
      WRITE (6,2) ((C(I,J),J = 1,3),I = 1,5)
      WRITE (6,*) "... written as A(row,column):"
      WRITE (6,1) ((A(I,J),J = 1,5),I = 1,3)

      WRITE (6,*)
      WRITE (6,*) "B = Transpose(A)"
      DO 10 I = 1,3
        DO 10 J = 1,5
   10     B(J,I) = A(I,J)

      WRITE (6,*) "Five rows of three values:"
      WRITE (6,2) B
      WRITE (6,*) "... written as B(row,column):"
      WRITE (6,2) ((B(I,J),J = 1,3),I = 1,5)

    1 FORMAT (5F6.1)	!Five values per line.
    2 FORMAT (3F6.1)	!Three values per line.
      END


module quad_mod
    implicit none

    private
    public :: quad

contains

    function quad(f, a, b) result(q_f)
        use :: types_mod, only : dp
        use :: quad_func_interface
        implicit none
        procedure(quad_func_type) :: f
        real(kind=dp), intent(in) :: a, b
        real(kind=dp) :: q_f
        q_f = (f(b) + f(a))*(b - a)
    end function quad

end module quad_mod


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine multi_pole(dipole_m,qd_pole_m,norm_m)
  use global_variables
  implicit none
!  real(dp),intent(out) :: dipole_t ,norm_t
  real(dp) :: dipole_m, qd_pole_m, norm_m
  integer :: ix,iy

  dipole_m = 0d0; qd_pole_m = 0d0; norm_m = 0d0
  do iy = 0,NR
    do ix = 0,Nx
      dipole_m = dipole_m + xn(ix)*abs(zwfn(ix,iy))**2
      qd_pole_m = qd_pole_m + Rn(iy)**2*abs(zwfn(ix,iy))**2
      norm_m = norm_m + abs(zwfn(ix,iy))**2
    end do
  end do

  dipole_m = dipole_m*dx*dr
  qd_pole_m = qd_pole_m*dx*dr
  norm_m = norm_m*dx*dr

  return
end subroutine multi_pole