    !This module provides the initial power spectra, parameterized as an expansion in ln k
    !
    ! ln P_s = ln A_s + (n_s -1)*ln(k/k_0_scalar) + n_{run}/2 * ln(k/k_0_scalar)^2 + n_{runrun}/6 * ln(k/k_0_scalar)^3
    !
    ! so if n_{run} = 0, n_{runrun}=0
    !
    ! P_s = A_s (k/k_0_scalar)^(n_s-1)
    !
    !for the scalar spectrum, when n_s=an(in) is the in'th spectral index. k_0_scalar
    !is a pivot scale, fixed here to 0.05/Mpc (change it below as desired or via .ini file).
    !
    !The tensor spectrum has three different supported parameterizations giving
    !
    ! ln P_t = ln A_t + n_t*ln(k/k_0_tensor) + n_{t,run}/2 * ln(k/k_0_tensor)^2
    !
    ! tensor_parameterization==tensor_param_indeptilt (=1) (default, same as CAMB pre-April 2014)
    !
    ! A_t = r A_s
    !
    ! tensor_parameterization==tensor_param_rpivot (=2)
    !
    ! A_t = r P_s(k_0_tensor)
    !
    ! tensor_parameterization==tensor_param_AT (=3)
    !
    ! A_t =  tensor_amp
    !
    !The absolute normalization of the Cls is unimportant here, but the relative ratio
    !of the tensor and scalar Cls generated with this module will be correct for general models
    !
    !December 2003 - changed default tensor pivot to 0.05 (consistent with CMBFAST 4.5)
    !April 2014 added different tensor parameterizations, running of running and running of tensors

    module InitialPower
    use Precision
    implicit none

    private

    character(LEN=*), parameter :: Power_Name = 'power_tilt'

    integer, parameter :: nnmax= 5
    !Maximum possible number of different power spectra to use

    integer, parameter, public :: tensor_param_indeptilt=1,  tensor_param_rpivot = 2, tensor_param_AT = 3

    Type InitialPowerParams
        integer :: tensor_parameterization = tensor_param_indeptilt
        integer nn  !Must have this variable
        !The actual number of power spectra to use

        !For the default implementation return power spectra based on spectral indices
        real(dl) an(nnmax) !scalar spectral indices
        real(dl) n_run(nnmax) !running of spectral index
        real(dl) n_runrun(nnmax) !running of spectral index
        real(dl) ant(nnmax) !tensor spectral indices
        real(dl) nt_run(nnmax) !tensor spectral index running
        real(dl) rat(nnmax) !ratio of scalar to tensor initial power spectrum amplitudes
        real(dl) k_0_scalar, k_0_tensor !pivot scales
        real(dl) ScalarPowerAmp(nnmax)
        real(dl) TensorPowerAmp(nnmax) !A_T at k_0_tensor if tensor_parameterization==tensor_param_AT
    end Type InitialPowerParams

    real(dl) curv  !Curvature contant, set in InitializePowers

    Type(InitialPowerParams), save :: P

    !Make things visible as neccessary...

    public InitialPowerParams, InitialPower_ReadParams, InitializePowers, ScalarPower, TensorPower
    public nnmax,Power_Descript, Power_Name, SetDefPowerParams
    contains

    subroutine SetDefPowerParams(AP)
    Type (InitialPowerParams) :: AP

    AP%nn     = 1 !number of initial power spectra
    AP%an     = 1 !scalar spectral index
    AP%n_run   = 0 !running of scalar spectral index
    AP%n_runrun   = 0 !running of running of scalar spectral index
    AP%ant    = 0 !tensor spectra index
    AP%nt_run   = 0 !running of tensor spectral index
    AP%rat    = 1
    AP%k_0_scalar = 0.05
    AP%k_0_tensor = 0.05
    AP%ScalarPowerAmp = 1
    AP%TensorPowerAmp = 1
    AP%tensor_parameterization = tensor_param_indeptilt

    end subroutine SetDefPowerParams

    subroutine InitializePowers(AParamSet,acurv)
    Type (InitialPowerParams) :: AParamSet
    !Called before computing final Cls in cmbmain.f90
    !Could read spectra from disk here, do other processing, etc.

    real(dl) acurv

    if (AParamSet%nn > nnmax) then
        write (*,*) 'To use ',AParamSet%nn,'power spectra you need to increase'
        write (*,*) 'nnmax in power_tilt.f90, currently ',nnmax
    end if
    P = AParamSet

    curv=acurv

    !Write implementation specific code here...

    end subroutine InitializePowers

    function ScalarPower(k,ix)

    !"ix" gives the index of the power to return for this k
    !ScalarPower = const for scale invariant spectrum
    !The normalization is defined so that for adiabatic perturbations the gradient of the 3-Ricci
    !scalar on co-moving hypersurfaces receives power
    ! < |D_a R^{(3)}|^2 > = int dk/k 16 k^6/S^6 (1-3K/k^2)^2 ScalarPower(k)
    !In other words ScalarPower is the power spectrum of the conserved curvature perturbation given by
    !-chi = \Phi + 2/3*\Omega^{-1} \frac{H^{-1}\Phi' - \Psi}{1+w}
    !(w=p/\rho), so < |\chi(x)|^2 > = \int dk/k ScalarPower(k).
    !Near the end of inflation chi is equal to 3/2 Psi.
    !Here nu^2 = (k^2 + curv)/|curv|

    !This power spectrum is also used for isocurvature modes where
    !< |\Delta(x)|^2 > = \int dk/k ScalarPower(k)
    !For the isocurvture velocity mode ScalarPower is the power in the neutrino heat flux.

    real(dl) ScalarPower,k, lnrat
    integer ix

    lnrat = log(k/P%k_0_scalar)
    ScalarPower=P%ScalarPowerAmp(ix)*exp(lnrat*( P%an(ix)-1 + lnrat*(P%n_run(ix)/2 + P%n_runrun(ix)/6*lnrat)))

    !         ScalarPower = ScalarPower * (1 + 0.1*cos( lnrat*30 ) )

    end function ScalarPower

    function TensorPower(k,ix)

    !TensorPower= const for scale invariant spectrum
    !The normalization is defined so that
    ! < h_{ij}(x) h^{ij}(x) > = \sum_nu nu /(nu^2-1) (nu^2-4)/nu^2 TensorPower(k)
    !for a closed model
    ! < h_{ij}(x) h^{ij}(x) > = int d nu /(nu^2+1) (nu^2+4)/nu^2 TensorPower(k)
    !for an open model
    !"ix" gives the index of the power spectrum to return
    !Here nu^2 = (k^2 + 3*curv)/|curv|

    real(dl) TensorPower,k
    real(dl), parameter :: PiByTwo=3.14159265d0/2._dl
    integer ix
    real(dl) lnrat, k_dep

    lnrat = log(k/P%k_0_tensor)
    k_dep = exp(lnrat*(P%ant(ix) + P%nt_run(ix)/2*lnrat))
    if (P%tensor_parameterization==tensor_param_indeptilt) then
        TensorPower = P%rat(ix)*P%ScalarPowerAmp(ix)*k_dep
    else if (P%tensor_parameterization==tensor_param_rpivot) then
        TensorPower = P%rat(ix)*ScalarPower(P%k_0_tensor,ix) * k_dep
    else if (P%tensor_parameterization==tensor_param_AT) then
        TensorPower = P%TensorPowerAmp(ix) * k_dep
    end if
    if (curv < 0) TensorPower=TensorPower*tanh(PiByTwo*sqrt(-k**2/curv-3))

    end function TensorPower

    !Get parameters describing parameterisation (for FITS file)
    !Does not support running extensions
    function Power_Descript(in, Scal, Tens, Keys, Vals)
    character(LEN=8), intent(out) :: Keys(*)
    real(dl), intent(out) :: Vals(*)
    integer, intent(IN) :: in
    logical, intent(IN) :: Scal, Tens
    integer num, Power_Descript
    num=0
    if (Scal) then
        num=num+1
        Keys(num) = 'n_s'
        Vals(num) = P%an(in)
        num=num+1
        Keys(num) = 'n_run'
        Vals(num) = P%n_run(in)
        num=num+1
        Keys(num) = 's_pivot'
        Vals(num) = P%k_0_scalar
    end if
    if (Tens) then
        num=num+1
        Keys(num) = 'n_t'
        Vals(num) = P%ant(in)
        num=num+1
        Keys(num) = 't_pivot'
        Vals(num) = P%k_0_tensor
        if (Scal) then
            num=num+1
            Keys(num) = 'p_ratio'
            Vals(num) = P%rat(in)
        end if
    end if
    Power_Descript = num

    end  function Power_Descript

    subroutine InitialPower_ReadParams(InitPower, Ini, WantTensors)
    use IniFile
    Type(InitialPowerParams) :: InitPower
    Type(TIniFile) :: Ini
    logical, intent(in) :: WantTensors
    integer i

    InitPower%k_0_scalar = Ini_Read_Double_File(Ini,'pivot_scalar',InitPower%k_0_scalar)
    InitPower%k_0_tensor = Ini_Read_Double_File(Ini,'pivot_tensor',InitPower%k_0_tensor)
    InitPower%nn = Ini_Read_Int_File(Ini,'initial_power_num',1)
    if (InitPower%nn>nnmax) stop 'Too many initial power spectra - increase nnmax in InitialPower'
    if (WantTensors) then
        InitPower%tensor_parameterization =  Ini_Read_Int_File(Ini, 'tensor_parameterization',tensor_param_indeptilt)
        if (InitPower%tensor_parameterization < tensor_param_indeptilt .or. &
        & InitPower%tensor_parameterization > tensor_param_AT) &
        & stop 'InitialPower: unknown tensor_parameterization'
    end if
    InitPower%rat(:) = 1
    do i=1, InitPower%nn
        InitPower%an(i) = Ini_Read_Double_Array_File(Ini,'scalar_spectral_index', i)
        InitPower%n_run(i) = Ini_Read_Double_Array_File(Ini,'scalar_nrun',i,0._dl)
        InitPower%n_runrun(i) = Ini_Read_Double_Array_File(Ini,'scalar_nrunrun',i,0._dl)

        if (WantTensors) then
            InitPower%ant(i) = Ini_Read_Double_Array_File(Ini,'tensor_spectral_index',i)
            InitPower%nt_run(i) = Ini_Read_Double_Array_File(Ini,'tensor_nrun',i,0._dl)
            if (InitPower%tensor_parameterization == tensor_param_AT) then
                InitPower%TensorPowerAmp(i) = Ini_Read_Double_Array_File(Ini,'tensor_amp',i)
            else
                InitPower%rat(i) = Ini_Read_Double_Array_File(Ini,'initial_ratio',i)
            end if
        end if

        InitPower%ScalarPowerAmp(i) = Ini_Read_Double_Array_File(Ini,'scalar_amp',i,1._dl)
        !Always need this as may want to set tensor amplitude even if scalars not computed
    end do

    end  subroutine InitialPower_ReadParams

    end module InitialPower


c***********************************************************************
      subroutine qss2dRK1Step(
     &  u_next,
     &  ilo_u_next_gb, ihi_u_next_gb,
     &  jlo_u_next_gb, jhi_u_next_gb,
     &  u_cur,
     &  ilo_u_cur_gb, ihi_u_cur_gb,
     &  jlo_u_cur_gb, jhi_u_cur_gb,
     &  rhs,
     &  ilo_rhs_gb, ihi_rhs_gb,
     &  jlo_rhs_gb, jhi_rhs_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb,
     &  dt)
c***********************************************************************
c { begin subroutine
      implicit none

      integer ilo_u_next_gb, ihi_u_next_gb
      integer jlo_u_next_gb, jhi_u_next_gb
      integer ilo_u_cur_gb, ihi_u_cur_gb
      integer jlo_u_cur_gb, jhi_u_cur_gb
      integer ilo_rhs_gb, ihi_rhs_gb
      integer jlo_rhs_gb, jhi_rhs_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb
      real u_next(ilo_u_next_gb:ihi_u_next_gb,
     &                        jlo_u_next_gb:jhi_u_next_gb)
      real u_cur(ilo_u_cur_gb:ihi_u_cur_gb,
     &                       jlo_u_cur_gb:jhi_u_cur_gb)
      real rhs(ilo_rhs_gb:ihi_rhs_gb,
     &                     jlo_rhs_gb:jhi_rhs_gb)
      integer i, j
      real dt

c     { begin loop over grid
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

            u_next(i,j) = u_cur(i,j) + dt*rhs(i,j)

          enddo
        enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************


subroutine nbody_grav_acceleration(position,acceleration)
! Calculates gravitational force between all bodies (brute force)
! given input positions
! IN THE HELIOCENTRIC FRAME (Keeps star at the centre)

! Calculated in units where G=1, M=msol, r=AU, t=2pi units/year

use embryodata
implicit none

real, dimension(3,nbodies),intent(in) :: position
real, dimension(3,nbodies), intent(out) :: acceleration

integer :: ix,ibody, jbody
real :: relpos,magipos,magjpos
real, dimension(3) :: sep

! Skip body 1 as we fix the star at the origin
do ibody=2,nbodies

   ! Ignore particles that have finished
   if(embryo(ibody-1)%finished==1) cycle

    ! Start by computing the force from the star
    magipos = sqrt(position(1,ibody)*position(1,ibody) + &
                position(2,ibody)*position(2,ibody)+ &
                position(3,ibody)*position(3,ibody))

    acceleration(:,ibody) = acceleration(:,ibody) - &
            (mass(1)+mass(ibody))*position(:,ibody)/(magipos*magipos*magipos)

    ! Again skip the central star
    do jbody=2,nbodies

       if(ibody==jbody) cycle ! Don't calculate force on itself

       ! Ignore particles that have finished
       if(embryo(jbody-1)%finished==1) cycle

        do ix=1,3
            sep(ix) = position(ix,ibody) - position(ix,jbody)
        enddo

        relpos = sqrt(sep(1)*sep(1) + sep(2)*sep(2)+sep(3)*sep(3) +rsoft*rsoft)

           magjpos = sqrt(position(1,jbody)*position(1,jbody) + &
                position(2,jbody)*position(2,jbody)+ &
                position(3,jbody)*position(3,jbody))

           do ix=1,3
              acceleration(ix,ibody) = acceleration(ix,ibody) - &
                   mass(jbody)*sep(ix)/(relpos*relpos*relpos) - &
                   mass(jbody)*position(ix,jbody)/(magjpos*magjpos*magjpos)
           enddo

        enddo

enddo

return
end subroutine nbody_grav_acceleration


! File: spanlib.f90
!
! This file is part of the SpanLib library.
! Copyright (C) 2006-2009  Stephane Raynaud
! Contact: stephane dot raynaud at gmail dot com
!
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.

! This library is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

module spanlib

	implicit none

contains

	! ############################################################
	! ############################################################
	! ## PCA PART ################################################
	! ############################################################
	! ############################################################

	subroutine sl_pca(var,nkeep,xeof,pc,ev,ev_sum,weights,useteof, bigmat)

		! **Principal Component Analysis**
		!
		! :Description:

		!	Perform a decomposition of space-time field in a set of
		!	Empirical Orthogonal Functions (EOFs) and Principal components (PCs).
		!	The input data set can be optionally weighted in space.
		!	By default, the analysis computes  "temporal" (T) or classical
		!	spatial (S) EOFs depending on if the space dimension is greater
		!	than the time dimension. This default behavior can be overridden.
		!
		! :Necessary arguments:
		!
		!	- *var (ns,nt)*: Data
		!	- *nkeep*: Maximum number of modes to keep in outputs
		!
		! :Optional arguments:
		!
		!	- *xeof (ns,nkeep)*: Space-mode array of EOFs
		!	- *pc (nt,nkeep)*: Time-mode array of PCs
		!	- *ev (nkeep)*: Mode array of eigen values (variances)
		!	- *ev_sum*: Sum of all egein values (even thoses not returned)
		!	- *weights (ns)*: Space array of weights
		!	- *useteof*: To force the use of T or S EOFs [0 = T, 1 = S, -1 = default]
		!	- *bigmat*: Use syevd instead of syev (faster for large
		!      matrices, but uses more workspace) [default:.true.]
		!
		! :Dependencies:
		!	:func:`[sd]gemm` (BLAS) :func:`[sd]syrk` (BLAS)
		!    :func:`syev` (LAPACK95) :func:`syevd` (LAPACK95)

		! Declarations
		! ============

		use spanlib_lapack95, only: syevd=>la_syevd, syev=>la_syev

		implicit none

		! External
		! --------
		real, intent(in)            :: var(:,:)
		integer,  intent(in)	        :: nkeep
		real, intent(out), optional :: pc(size(var,2),nkeep), &
		&                                xeof(size(var,1),nkeep), ev(nkeep)
		real, intent(in),  optional :: weights(:)
		integer,  intent(in),  optional :: useteof
		logical,  intent(in),  optional :: bigmat
		real, intent(out), optional :: ev_sum

		! Internal
		! --------
		integer               :: ns,nt
		real, allocatable :: cov(:,:), subcov(:,:)
		real, allocatable :: wvar(:,:), ww(:), zeof(:,:), zvar(:,:)
		real, allocatable :: zev(:)
		integer               :: zuseteof, znkeepmax, i
		logical               :: zbigmat

		! Setups
		! ======

		! Sizes
		! -----
		ns = size(var,1)
		nt = size(var,2)
		znkeepmax = 100
		if(nkeep>znkeepmax)then
			print*,'[pca] You want to keep a number of PCs '//&
			 & 'greater than ',znkeepmax
			stop 1
		end if

		! What does the user want?
		! ------------------------
		if(.not.present(xeof).and..not.present(pc)&
		  &.and..not.present(ev))then
			print*,'[pca] Nothing to do. Quit.'
			return
		end if

		! By default, T-EOF decompostion if ns > nt
		! -----------------------------------------
		zuseteof = -1
		if(present(useteof))zuseteof = useteof
		if(zuseteof<0)then
			if(ns>nt)then
				zuseteof=1
			else
				zuseteof=0
			endif
		endif
		znkeepmax=100
		if(zuseteof==1)then
			if(nkeep>nt)then
				print*,'[pca] You want to keep a number of PCs '//&
					&'greater than the number of EOF:',nt
				return
			end if
		else
			if(nkeep>ns)then
				print*,'[pca] You want to keep a number of PCs '//&
					&'greater than the number of EOF:',ns
				return
			end if
		end if

		! Use ssyevd?
		! -----------
		if(.not.present(bigmat))then
			zbigmat = .true.
		else
			zbigmat = bigmat
		end if

		! Remove the mean
		! ---------------
		allocate(zvar(ns,nt))
		zvar = var - spread(sum(var,dim=2)/real(nt), ncopies=nt, dim=2)

		! Default weights = 1.
		! --------------------
		allocate(ww(ns))
		allocate(wvar(ns,nt))
		ww = 1.
		if(present(weights))then
			ww(:) = weights * real(ns) / sum(weights)
			where(ww==0.)ww = 1.
			do i = 1, nt
				wvar(:,i) = zvar(:,i) * sqrt(ww)
			end do
		else
			wvar = zvar
		end if

		! EOF decomposition
		! =================

		if(zuseteof==1)then

			! T-EOF case
			! ----------

			! Covariance
			allocate(cov(nt,nt))
			allocate(zev(nt))
			cov=0.
			call ssyrk('U','T',nt,ns,1.,wvar,ns, 0.,cov,nt)
			cov = cov / float(ns)
			deallocate(wvar)

			! Diagonalising (cov: input=cov, output=eof)
			if(zbigmat)then
				call syevd(cov,zev,jobz='V')
			else
				call syev(cov,zev,jobz='V')
			end if

			! Back to S-EOFs
			if(present(pc).or.present(xeof))then
				allocate(zeof(ns,nkeep))
				allocate(subcov(nt,nkeep))
				subcov = cov(:,nt:nt-nkeep+1:-1)
				deallocate(cov)
				call sgemm('N','N',ns,nkeep,nt,1.,zvar,ns, &
					& subcov,nt,0.,zeof,ns)
				deallocate(subcov)
				do i = 1, nkeep
					zeof(:,i) = zeof(:,i) / &
					 &          sqrt(dot_product(ww(:), zeof(:,i)**2))
				end do
				if(.not.present(pc)) deallocate(ww)
			else
				deallocate(cov)
			end if

			! Eigenvalues
			! -----------
			if(present(ev)) ev = zev(nt:nt-nkeep+1:-1)

		else

			! S-EOF case (classical)
			! ----------------------

			! Covariance
			allocate(cov(ns,ns))
			allocate(zev(ns))
			cov = 0.
			call ssyrk('U','N',ns,nt,1.,wvar,ns, 0.,cov,ns)
			cov = cov / float(nt)
			deallocate(wvar)

			! Diagonalisation (cov: input=cov, output=eof)
			if(zbigmat)then
				call syevd(cov,zev,jobz='V')
			else
				call syev(cov,zev,jobz='V')
			end if

			! Formatting S-EOFs
			if(present(xeof).or.present(pc))then
				allocate(zeof(ns,nkeep))
				do i = 1, nkeep
					zeof(:,i) = cov(:,ns-i+1) / sqrt(ww(:))
				end do
			end if
		   deallocate(cov)

			! Eigenvalues
			! -----------
			if(present(ev)) ev = zev(ns:ns-nkeep+1:-1)

		end if

		! Sum of all eigenvalues (useful for percentils)
		! ----------------------------------------------
		if(present(ev_sum)) ev_sum = sum(zev)

		! Free eof array
		! --------------
		if(present(xeof))then
			xeof = zeof
			if(.not.present(pc)) deallocate(zeof)
		end if

		! Finally get PCs
		! ===============
		if(present(pc))then
			if(present(weights))then
				call sl_pca_getec(zvar, zeof, pc, weights=ww)
			else
				call sl_pca_getec(zvar, zeof, pc)
			end if
		end if

	end subroutine sl_pca

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_pca_getec(var, xeof, ec, weights)

		! **Compute PCA expansion coefficients**
		!
		! :Description:
		!
		!	Get an expansion coefficients from a space-time field
		!	and a set of EOFs computed by PCA. If the input
		!	space-time field is the same as the one used to computes
		!	input ST-EOFs, these expansion coincide with the
		!	associated principal components.
		!
		! :Necessary arguments:

		!	- *var (ns, nt)*: Data
		!	- *xeof (ns, nkeep)*: EOFs
		!	- *ec (nt, nmode)*: Expansion coefficients
		!
		! :Optional arguments:
		!
		!	- *weights (ns)*: Weights

		implicit none

		! Declarations
		! ============

		! External
		! --------
		real, intent(in)           :: var(:,:), xeof(:,:)
		real, intent(out)          :: ec(size(var,2),size(xeof,2))
		real, intent(in), optional :: weights(:)

		! Internal
		! --------
		real :: zweights(size(var,1)), zvar(size(var,1),size(var,2))
		integer :: ns,nt,nkeep,i

		! Computations
		! ============

		! Initialisations
		! ---------------

		ns = size(var,1)
		nt = size(var,2)
		nkeep = size(xeof,2)

		if(present(weights))then
			zweights = weights
			do i=1, nt
				zvar(:,i) = var(:,i) * zweights
			end do
		else
			zweights = 1.
			zvar = var
		end if

		! Main stuff
		! ----------
		! ec = matmul( transpose(var), xeof) ! Not efficient
		call sgemm('T','N',nt,nkeep,ns,1.,zvar,ns,xeof,ns,0.,ec,nt)
		do i = 1, nkeep
			ec(:,i) = ec(:,i) / dot_product(xeof(:,i)**2, zweights)
		end do

	end subroutine sl_pca_getec

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_pca_rec(xeof, pc, varrec, istart, iend)

		! **Reconstruction of a set of PCA components**
		!
		! :Description:
		!
		!	Perform a reconstruction using a set of components previously
		!	computed with a PCA. All the reconstructed components are summed.
		!	A reconstructed component is simply the "product" of an EOF
		!	by its PC. The sum of all reconstructed component is the original field.
		!
		! :Necessary arguments:
		!
		!	- *xeof (ns,nkeep)*: Space-mode array of EOFs
		!	- *pc (nt,nkeep)*: Time-mode array of PCs
		!	- *varrec (ns,nt)*: Space-time array of the reconstructed field
		!
		! :Optional arguments:
		!
		!	- *istart*: Index of the first component to use
		!	- *iend*: Index of the last component to use

		! Declarations
		! ============

		implicit none

		! External
		! --------
		real,	intent(in)     :: xeof(:,:), pc(:,:)
		real,	intent(out)    :: varrec(size(xeof,1),size(pc,1))
		integer,intent(in),	optional	:: istart, iend

		! Internal
		! --------
		integer           :: nkept, itmp, zistart, ziend, nt, ns, i
		real, allocatable	:: zpc(:,:)

		! Setup
		! =====
		nkept = size(xeof,2)
		zistart=1
		if(present(istart))zistart=istart
		if(present(iend))then
			ziend=iend
		else
			ziend=nkept
		end if
		if(zistart.lt.1.or.zistart.gt.nkept)then
			zistart=1
			print*,'[pca_rec] istart lower than 1 => set to 1'
		end if
		if(ziend.lt.1.or.ziend.gt.nkept)then
			ziend=nkept
			print*,'[pca_rec] iend greater than the number '//&
				&'of avalaible modes => reduced to ',ziend
		end if
		if(zistart>ziend)then
			itmp=ziend
			ziend=zistart
			zistart=itmp
			print*,'[pca_rec] istart > iend => inversion'
		end if
		ns = size(xeof,1)
		nt = size(pc,1)

		! Computation
		! ===========
		varrec = 0.
		if(nt<ns) then
			do i = 1, nt
				varrec(:, i) = varrec(:, i) + &
					&	matmul(xeof(:, zistart:ziend), pc(i, zistart:ziend))
			end do
		else
			allocate(zpc(ziend-zistart+1, nt))
			zpc = transpose(pc(:, zistart:ziend))
			do i = 1, ns
				varrec(i, :) = varrec(i, :) + &
					&	matmul(xeof(i, zistart:ziend), zpc)
			end do
			deallocate(zpc)
		end if

	end subroutine sl_pca_rec

  !############################################################
  !############################################################
  !## MSSA PART ###############################################
  !############################################################
  !############################################################

	subroutine sl_mssa(var, nwindow, nkeep, steof, stpc, ev, ev_sum, bigmat)

		! **Multi-channel Singular Spectrum Analysis**
		!
		! :Description:
		!
		!	Perform a decomposition of space-time field in a set of
		!	space-time Empirical Orthogonal Functions (EOFs) and
		!	time Principal components (PCs), according to a window
		!	parameter.
		!
		! :Necessary arguments:
		!
		!	- *var*:      Space-time array
		!	- *nwindow*: Window size
		!	- *nkeep*:   Maximum number of modes to keep in outputs
		!
		! :Optional arguments:
		!
		!	- *steof*: Space-window-mode array of EOFs
		!	- *stpc*: Time-mode array of PCs
		!	- *ev*: Mode array of eigen values (variances)
		!	- *ev_sum*: Sum of all eigen values (even thoses not returned)
		!	- *bigmat*: Use ssyevd instead of ssyev (faster for large matrices,
		!	  but uses more workspace) [default:.true.]
		!
		! :Dependencies:
		!	:func:`sl_stcov` :func:`syev(LAPACK95)` :func:`syevd(LAPACK95)`

		! Declarations
		! ============

		use spanlib_lapack95, only: syevd=>la_syevd, syev=>la_syev

		implicit none

		! External
		! --------
		real, intent(in)            :: var(:,:)
		integer,  intent(in)            :: nwindow, nkeep
		real, intent(out), optional :: &
			& steof(size(var,1)*nwindow, nkeep), &
			& stpc(size(var,2)-nwindow+1, nkeep), ev(nkeep)
		logical,  intent(in),  optional :: bigmat
		real, intent(out), optional :: ev_sum

		! Internal
		! --------
		real, allocatable :: cov(:,:), zev(:), &
			& zvar(:,:), zsteof(:,:)
		integer :: nchan, nsteof, nt, znkeepmax
		logical :: zbigmat

		! Setup
		! =====

		! Sizes
		! -----
		nchan = size(var,1)
		nsteof = nchan * nwindow
		nt = size(var,2)
		znkeepmax = 100
		if(nkeep>znkeepmax)then
			print*,'[mssa] You want to keep a number of PCs '//&
			 & 'greater than ',znkeepmax
			return
		else if(nkeep>nsteof) then
			print*,'[mssa] You want to keep a number of PCs greater '// &
				& 'than the number of ST-EOFs:',nsteof
			return
		end if

		! Use ssyevd?
		! -----------
		if(.not.present(bigmat))then
			zbigmat = .true.
		else
			zbigmat = bigmat
		end if

		! Remove the mean
		! ---------------
		allocate(zvar(nchan, nt))
		zvar = var - spread(sum(var,dim=2)/real(nt), ncopies=nt, dim=2)

		! Set the block-Toeplitz covariance matrix
		! ========================================
		allocate(cov(nsteof, nsteof))
		call sl_stcov(zvar, cov)
	!	do ic1 = 1, nchan
	!		do ic2 = 1, nchan
	!			do iw2 = 1, nwindow
	!				do iw1 = 1, iw2
	!					i1 = (ic1-1) * nwindow + iw1
	!					i2 = (ic2-1) * nwindow + iw2
	!					iw = iw2 - iw1 + 1
	!					cov(i1,i2) = &
	!						& dot_product(zvar(ic1, 1  : nt-iw+1),  &
	!						&             zvar(ic2, iw : nt	 )) / &
	!						& real(nt-iw+1)
	!					cov(i2,i1) = cov(i1,i2)
	!				end do
	!			end do
	!		end do
	!	end do

		! Diagonalisation
		! ===============
		allocate(zev(nsteof))
		if(zbigmat)then
			call syevd(cov,zev,jobz='V')
		else
			call syev(cov,zev,jobz='V')
		end if

		! Get ST-EOFs and eigenvalues
		! ===========================
		if(present(steof).or.present(stpc))then
			allocate(zsteof(nsteof, nkeep))
			zsteof = cov(:, nsteof : nsteof-nkeep+1 : -1)
			deallocate(cov)
			if(present(steof))then
				steof = zsteof
				deallocate(zsteof)
			end if
		end if

		! Eigen values
		! ------------
		if(present(ev))then
			ev = zev(nsteof : nsteof-nkeep+1 : -1)
		end if
		if(present(ev_sum)) ev_sum = sum(zev)
		deallocate(zev)

		! Get ST-PCs
		! ==========
		if(present(stpc)) call sl_mssa_getec(zvar, steof, nwindow, stpc)
		deallocate(zvar)

	end subroutine sl_mssa

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_stcov(var, cov)

	! Compute the Block-Toeplitz covariance matrix for MSSA analysis
	!
	! .. note:: ``var`` does not need to be centered

		implicit none

		real, intent(in)  :: var(:, :)
		real, intent(out) :: cov(:, :)

		real, allocatable :: varmean(:)
		integer ::  nchan, nt, nsteof, nwindow
		integer :: iw, iw1, iw2, i1, i2, ic1, ic2

		nchan = size(var, 1)
		nt = size(var, 2)
		nsteof = size(cov, 1)
		nwindow = nsteof/nchan

		allocate(varmean(nchan))
		varmean = sum(var, dim=2)/real(nt)

		do ic1 = 1, nchan
			do ic2 = 1, nchan
				do iw2 = 1, nwindow
					do iw1 = 1, iw2
						i1 = (ic1-1) * nwindow + iw1
						i2 = (ic2-1) * nwindow + iw2
						iw = iw2 - iw1 + 1
						cov(i1,i2) = &
							& dot_product(var(ic1, 1  : nt-iw+1)-varmean(ic1),  &
							&             var(ic2, iw : nt	 )-varmean(ic2)) / &
							& real(nt-iw+1)
						cov(i2,i1) = cov(i1,i2)
					end do
				end do
			end do
		end do

		deallocate(varmean)

	end subroutine sl_stcov

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_mssa_getec(var, steof, nwindow, stec)

	! Title:
	!	Computes MSSA expansion coefficients
	!
	! Description
	!	Get an expansion coefficients from a space-time field
	!	and a set of ST-EOFs computed by MSSA. If the input
	!	space-time field is the same as the one used to computes
	!	input ST-EOFs, these expansion coincide with the
	! associated principal components.
	!
	! :Necessary arguments:
	!	- var:   Space-time field
	!	- steof: Space-window-mode EOFs
	!	- stec:  Time-mode array of expansion coefficients
	!
	! :Dependencies:
	!	[sd]gemm(BLAS)

	implicit none

	! Declarations
	! ============

	! External
	! --------
	real, intent(in)  :: var(:,:), steof(:,:)
	real, intent(out) :: stec(size(var,2)-nwindow+1,&
		& size(steof,2))
	integer,       intent(in)  :: nwindow

	! Internal
	! --------
	integer :: nt,nkeep,im,iw,nchan
	real :: wpc(size(var,2)-nwindow+1),substeof(size(var,1)),&
		& subvar(size(var,1),size(var,2)-nwindow+1)

	! Computations
	! ------------

	! Initialisations
	! ---------------
	stec = 0.
	nchan = size(var,1)
	nt = size(var,2)
	nkeep = size(steof,2)

	! Main stuff
	! ----------
	do im = 1, nkeep
		do iw = 1, nwindow
			subvar = var(:,iw:iw+nt-nwindow)
			substeof = steof(iw:iw+(nchan-1)*nwindow:nwindow, im)
			call sgemm('T','N', nt-nwindow+1, 1, nchan, 1.,&
				& subvar, nchan, substeof, nchan, 0., wpc, nt-nwindow+1)
				stec(:, im)  =  stec(:, im) + wpc
		end do
		stec(:, im) = stec(:, im) / sum(steof(:,im)**2)
	end do

	end subroutine sl_mssa_getec

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_mssa_rec(steof, stpc, nwindow, varrec, istart, iend)

	! Title:
	!	Reconstruction of a set of MSSA components
	!
	! Description:
	!	Same as for the reconstruction of PCA components, but for MSSA.
	!
	! :Necessary arguments:
	!	- steof:   SpaceXwindow-mode array of EOFs
	!	- stpc:    Time-mode array of PCs
	!	- nwindow: Window size
	!	- varrec:   Space-time array of the reconstructed field
	!
	! :Optional arguments:
	!	- istart: Index of the first component to use
	!	- iend:   Index of the last component to use

	implicit none

	! Declarations
	! ============

	! External
	! --------
	real,   intent(in)  :: steof(:,:), stpc(:,:)
	real,   intent(out) :: varrec(size(steof, 1)/nwindow,&
	 &                                    size(stpc, 1)+nwindow-1)
	integer,intent(in)           :: nwindow
	integer,intent(in), optional :: istart, iend

	! Internal
	! --------
	integer :: ntpc, nchan, nt, ic, im, iw, nkept, &
	 &         itmp, zistart, ziend
	real, allocatable :: reof(:), epc(:,:)

	! Setup
	! =====

	! Sizes
	! -----
	ntpc  = size(stpc, 1)
	nt    = ntpc+nwindow-1
	nchan = size(steof, 1)/nwindow
	nkept = size(steof, 2)
	allocate(reof(nwindow))
	allocate(epc(nwindow, ntpc-nwindow+1))
	varrec = 0.

	! Range
	! -----
	if(present(iend))then
		ziend=iend
	else
		ziend=nkept
	end if
	if(present(istart))then
		zistart=istart
	else
		zistart = 1
	endif
	if(zistart.lt.1.or.zistart.gt.nkept)then
		zistart = 1
		print*,'[mssa_rec] istart lower than 1 => set to 1'
	end if
	if(ziend.lt.1.or.ziend.gt.nkept)then
		ziend = nkept
		print*,'[mssa_rec] iend greater than the number of '// &
		 &     'avalaible modes => reduced to',iend
	end if
	if(zistart>ziend)then
		itmp    = ziend
		ziend   = zistart
		zistart = itmp
		print*,'[mssa_rec] istart > iend => inversion'
	end if

	! Computation
	! ===========
	varrec = 0.
	do im = zistart, ziend ! sum over the selection of modes

		! (ntpc-nwindow+1) length slices
		do iw = 1, nwindow
			epc(iw,:) = stpc(iw : iw+ntpc-nwindow, im)
		end do

		do ic = 1, nchan ! sum over the channels (= space or PCs from simple PCA)

			! reversed eof
			reof = steof(nwindow+(ic-1)*nwindow : 1+(ic-1)*nwindow : -1, im)

			! * middle * [nwindow length projections]
			varrec(ic, nwindow : ntpc) =  varrec(ic, nwindow : ntpc) + &
				& matmul(reof, epc) / real(nwindow)

			do iw = 1, nwindow-1

			 ! * beginning * [iw length projections]
			 varrec(ic, iw) = varrec(ic, iw) + &
				  & dot_product(reof(nwindow-iw+1:nwindow), &
				  &	stpc(1:iw, im)           ) / real(iw)
!
			 ! * end * [iw length projections]
			 varrec(ic, nt-iw+1) = varrec(ic, nt-iw+1) + &
				  & dot_product(reof(1:iw), &
				  &	stpc(ntpc-iw+1:ntpc, im) ) / real(iw)

			end do

		end do

	end do

	deallocate(reof,epc)

	end subroutine sl_mssa_rec

  !############################################################
  !############################################################
  !## SVD PART ################################################
  !############################################################
  !############################################################

	subroutine sl_svd(ll,rr,nkeep,leof,reof,lpc,rpc,ev,ev_sum,lw,rw,usecorr,&
		& bigmat,info)

	! Title:
	!	Singular Value Decomposition
	!
	! Description:
	!	Singular value decomposition between two datasets having
	!	the same length in time.
	!
	! :Necessary arguments:
	!	- ll:    Left space-time array
	!	- rr:    Right space-time array
	!	- nkeep: Maximum number of modes to keep in outputs
	!
	! :Optional arguments:
	!	- leof:  Left EOFs
	!	- reof:  Right EOFs
	!	- lpc:   Left PCs
	!	- rpc:   Right PCs
	!	- ev:    Eigen values
	!	- lw:    Left weights
	!	- rw:    Right weights
	!	- usecorr:  Use correlations instead of covariances
	!	- bigmat: Use gesdd instead of gesvd (faster for large matrices, but uses more workspace) [default:.false.]
	!
	! :Dependencies:
	!	[sd]gemm(BLAS) gesvd(LAPACK95) gesdd(LAPACK95)

	! Declarations
	! ============

	use spanlib_lapack95, only: gesdd=>la_gesdd, gesvd=>la_gesvd
!	use spanlib_lapack95, only: gesdd, gesvd
!	use f95_lapack, only: gesdd => la_gesdd, gesvd => la_gesvd

	implicit none

	! External
	! --------
	real, intent(in)           :: ll(:,:),rr(:,:)
	integer,  intent(in)           :: nkeep
	real, intent(in), optional :: lw(:), rw(:)
	real, intent(out),optional :: lpc(size(ll,2),nkeep), &
		& leof(size(ll,1),nkeep), rpc(size(rr,2),nkeep), &
		& reof(size(rr,1),nkeep),ev(nkeep)
	logical, intent(in),  optional :: bigmat, usecorr
	real, intent(out), optional :: ev_sum
	integer, intent(out),  optional :: info

	! Internal
	! --------
	integer               :: ns,nsl,nsr,nt
	real, allocatable :: zll(:,:), zrr(:,:), cov(:,:), &
		&                    zlw(:), zrw(:), zls(:), zrs(:)
	real, allocatable :: zev(:), zleof(:,:)
	integer               :: znkeepmax, i, la_info
	logical               :: zbigmat,zbcorr

	! Sizes
	! -----
	info = 0
	nsl = size(ll,1)
	nsr = size(rr,1)
	nt = size(ll,2)
! 	if(nsl/=nsr.or.nt/=size(rr,2))then
	if(nt/=size(rr,2))then
		print*,'[svd] Left and right arrays have incompatible sizes'
		info = 1
		return
	end if
	ns = min(nsr,nsl)
	znkeepmax = 100
	if(nkeep>znkeepmax)then
		print*,'[svd] You want to keep a number of PCs '//&
		 & 'greater than ',znkeepmax
		info = 2
		return
	end if
	if(nkeep>ns)then
		print*,'[svd] You want to keep a number of PCs '//&
			&'greater than the number of EOF:',ns
		info = 3
		return
	end if

	! What does the user want?
	! ------------------------
	if(.not.present(leof).and..not.present(lpc).and.&
	  &.not.present(reof).and..not.present(rpc).and.&
	  &.not.present(ev))then
		print*,'[svd] Nothing to do. Quit.'
		return
	end if
	if(present(usecorr))then
		zbcorr = usecorr
	else
		zbcorr = .false.
	endif
	print *,'use corr ?',zbcorr

	! Use divide/conquer algo?
	! ------------------------
	if(.not.present(bigmat))then
		zbigmat = .false.
	else
		zbigmat = bigmat
	end if

	! Weights
	! -------
	allocate(zlw(nsl))
	if(present(lw))then
		zlw = lw * real(nsl) / sum(lw)
		where(zlw==0.) zlw = 1.
	else
		zlw = 1.
	end if
	allocate(zrw(nsl))
	if(present(rw))then
		zrw = rw * real(nsr) / sum(rw)
		where(zrw==0.) zrw = 1.
	else
		zrw = 1.
	end if

	! Remove the mean
	! ---------------
	allocate(zll(nsl,nt))
	zll = ll - spread(sum(ll,dim=2)/real(nt), ncopies=nt, dim=2)
	allocate(zrr(nsr,nt))
	zrr = rr - spread(sum(rr,dim=2)/real(nt), ncopies=nt, dim=2)

	! Standard deviation for correlations
	! -----------------------------------
	allocate(zls(nsl),zrs(nsl))
	if(zbcorr)then
		zls = sqrt(sum(zll**2,dim=2))/nsl
		zrs = sqrt(sum(zrr**2,dim=2))/nsr
		where(zls==0.) zls = 1.
		where(zrs==0.) zrs = 1.
	else
		zls = 1.
		zrs = 1.
	end if

	! Computations
	! ============

	! Weighting
	! ---------
	do i = 1, nt
		zll(:,i) = zll(:,i) * sqrt(zlw) / zls
		zrr(:,i) = zrr(:,i) * sqrt(zrw) / zrs
	end do

	! Cross-covariances
	! -----------------
	allocate(cov(nsl,nsr))
	call sgemm('N','T',nsl,nsr,nt,1.,zll,nsl,zrr,nsr,0.,cov,nsl)
	cov = cov / float(nt)
	if(.not.present(lpc)) deallocate(zll,zls)
	if(.not.present(rpc)) deallocate(zrr,zrs)

	! SVD
	! ---
	allocate(zleof(nsl,ns), zev(ns))
	if(zbigmat)then
		! FIXME: problem with gesdd
		call gesdd(cov, zev, u=zleof, job='V', info=la_info)
	else
		call gesvd(cov, zev, u=zleof, job='V', info=la_info)
	end if
	if(la_info /= 0)then
		info = la_info+10
		return
	endif

	! Get output arrays
	! =================

	! Sum of all eigenvalues (useful for percentils)
	! ----------------------------------------------
	if(present(ev_sum)) ev_sum = sum(zev)

	! Eigen values
	! ------------
	if(present(ev)) ev = zev(1:nkeep)
	deallocate(zev)

	! EOFs
	! ----
	if(present(leof).or.present(lpc))then
		leof = zleof(:,1:nkeep)
		deallocate(zleof)
	end if
	if(present(reof).or.present(rpc))then
		do i = 1, nkeep
			reof(:, i) = cov(i,:)
		end do
		deallocate(cov)
	end if

	! PCs
	! ---
	if(present(lpc))then
		do i = 1, nt
			zll(:,i) = zll(:,i) * zls ! Correlation case
		end do
		deallocate(zls)
		call sl_pca_getec(zll,leof,lpc,weights=zlw)
		deallocate(zll,zlw)
	end if
	if(present(rpc))then
		do i = 1, nt
			zrr(:,i) = zrr(:,i) * zrs ! Correlation case
		end do
		deallocate(zrs)
		call sl_pca_getec(zrr,reof,rpc,weights=zrw)
		deallocate(zrr,zrw)
	end if

	end subroutine sl_svd

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_svd_model_setup(ll,rr,lPcaEof,rPcaEof,&
		& lSvdEof,rSvdEof,l2r,lPcaPc,rPcaPc,lSvdPc,rSvdPc)

	! Title:
	!	SVD statistical model - Setup part
	!
	! Description:
	!	Build a SVD-based statistical model to deduce right field
	!	from left field. First, it performs pre-PCA on both dataset,
	!	then it decomposes resulting PCs using a SVD.
	!	Outputs EOFs and PCs from PCA and SVD can further be used
	!	by the model part.
	!
	! :Necessary arguments:
	!	- ll:    Left space-time array
	!	- rr:    Right space-time array
	!	- lPcaEof:  Left pre-PCA EOFs
	!	- rPcaEof:  Right pre-PCA EOFs
	!	- lSvdEof:  Left SVD EOFs
	!	- rSvdEof:  Right SVD EOFs
	!	- l2r:      Scale factors to convert from left to right
	!	- lPcsPc:   Left pre-PCA PCs
	!	- rPcsPc:   Right pre-PCA PCs
	!	- lPcsPc:   Left SVD PCs
	!	- rPcsPc:   Right SVD PCs

	! Declarations
	! ============

	implicit none

	! External
	! --------
	real, intent(in) :: ll(:,:), rr(:,:)
	real, intent(out) ::lPcaEof(:,:), rPcaEof(:,:),&
	 & lsvdEof(:,:), rSvdEof(:,:), l2r(:)
	real, intent(out), optional :: &
	 & lPcaPc(size(ll,2),size(lPcaEof,2)), &
	 & rPcaPc(size(ll,2),size(rPcaEof,2)), &
	 & lSvdPc(size(ll,2),size(lSvdEof,2)), &
	 & rSvdPc(size(ll,2),size(rSvdEof,2))

	! Internal
	! --------
	integer :: i,nt,nkeepPca, nkeepSvd, nsl, nsr, info

	! Sizes
	! -----
	nt = size(ll,2)
	nkeepPca = size(lPcaEof,2)
	nkeepSvd = size(lSvdEof,2)
	nsl = real(size(ll,1))
	nsr = real(size(rr,1))

	! Computations
	! ============

	! Pre-PCA
	! -------
	call sl_pca(ll, nkeepPca, xeof=lPcaEof, pc=lPcaPc)
	call sl_pca(rr, nkeepPca, xeof=rPcaEof, pc=rPcaPc)

	! SVD
	! ---
	call sl_svd(transpose(lPcaPc),transpose(rPcaPc),nkeepSvd, &
		& leof=lSvdEof, reof=rSvdEof, lpc=lSvdPc, rpc=rSvdPc, info=info)

	! Scale factors based on standard deviations
	! -----------------------------------------
	do i = 1, nkeepSVD
		l2r(i) = sqrt((sum(rSvdPc(:,i)**2)/nsr - &
		 &             (sum(rSvdPc(:,i))/nsr)**2) / &
		 &            (sum(lSvdPc(:,i)**2)/nsr - &
		 &             (sum(lSvdPc(:,i))/nsl)**2))
	end do

	end subroutine sl_svd_model_setup

	!############################################################
	!############################################################
	!############################################################

	subroutine sl_svd_model_run(ll,rr,&
		& lPcaEof,rPcaEof,lSvdEof,rSvdEof,l2r)

 	! Title:
	!	SVD statistical model - Run part
	!
	! Description:
	!	SVD-based statistical model to deduce right field
	!	from left field. It uses results from pre-PCA
	!	and SVD decompositions performed by sl_svdmodel_build.
	!
	! :Necessary arguments:
	!	- ll:    Left space array
	!	- rr:    Right space array
	!	- lPcaEof:  Left pre-PCA EOFs
	!	- rPcaEof:  Right pre-PCA EOFs
	!	- lSvdEof:  Left pre-SVD EOFs
	!	- rSvdEof:  Right pre-SVD EOFs
	!	- l2r:      Scale factors to convert from left to right
	!
	! :Dependencies:
	!	sl_pca_getec sl_pca_rec

	! Declarations
	! ============

	implicit none

	! External
	! --------
	real, intent(in) :: ll(:), lPcaEof(:,:), rPcaEof(:,:),&
	 & lSvdEof(:,:), rSvdEof(:,:), l2r(:)
	real, intent(out) :: rr(:)

	! Internal
	! --------
	integer :: i,nt,nkeepPca, nkeepSvd
	real, allocatable :: zlPcaEc(:,:),zlSvdEc(:,:),&
		& zrSvdEc(:,:),zrPcaPc(:,:),zll(:,:),zrr(:,:)

	! Computations
	! ============

	! Size
	! ----
	nt = 1
	nkeepPca = size(lPcaEof,2)
	nkeepSvd = size(rSvdEof,2)

	! Get expansion coefficients from re-PCA
	! --------------------------------------
	allocate(zll(size(ll,1),1),zlPcaEc(nt,nkeepPca))
	zll(:,1) = ll
	call sl_pca_getec(zll,lPcaEof,zlPcaEc)
	allocate(zlSvdEc(nt,nkeepSvd))
	call sl_pca_getec(transpose(zlPcaEc),lSvdEof,zlSvdEc)
	deallocate(zll,zlPcaEc)

	! Scale factorisation from left to right
	! --------------------------------------
	allocate(zrSvdEc(nt,nkeepSvd))
	do i = 1, nkeepSvd
		zrSvdEc(:,i) = l2r(i) * zlSvdEc(:,i)
	end do
	deallocate(zlSvdEc)

	! Reconstructions
	! ---------------
	allocate(zrPcaPc(nkeepPca,nt))
	call sl_pca_rec(rSvdEof,zrSvdEc,zrPcaPc)
	deallocate(zrSvdEc)
	allocate(zrr(size(rr,1),1))
	call sl_pca_rec(rPcaEof,transpose(zrPcaPc),zrr)
	rr = zrr(:,1)
	deallocate(zrr,zrPcaPc)

	end subroutine sl_svd_model_run

  ! ############################################################
  ! ############################################################
  ! ## TOOLS PART ##############################################
  ! ############################################################
  ! ############################################################

	subroutine sl_phasecomp(varrec,np,phases,weights,offset,firstphase)

	! Title:
	!	Phase composites
	!
	! Description:
	!	Performs phase composites of S-T oscillatory field.
	!	This field is typically a reconstructed pair of MSSA modes.
	!	Composites are evaluated according to an index defined by the
	!	first PC of the input field and its derivative.
	!	Space weights can be optionally used to compute the PC.
	!	A minimal normalized amplitude can be also used: when the
	!	index is under value, data are not used to compute phases.
	!	It is also possible so specify the angle of the first phase
	!	in the 360 degrees phase diagram circle: zero means the
	!	the first phase conincides with the maximmum.
	!
	!
	! :Necessary arguments:
	!	- varrec: Space-time array
	!	- np:    Number of requested phases over the 360 degrees cycle [default:8]
	!
	! :Optional arguments:
	!	- weights:    Space array of weights
	!	- offset:     Minimal normalized amplitude of the index [default:0.]
	!	- firstphase: Value in degrees of the first phase [default:0.]
	!
	! :Dependencies:
	!	sl_pca

	implicit none

	! Declarations
	! ============

	! External
	! --------
	integer,       intent(in)           :: np
	real, intent(in)           :: varrec(:,:)
	real, intent(in), optional :: weights(:)
	real, intent(in), optional :: offset, firstphase
	real, intent(out)          :: phases(size(varrec, 1),np)

	! Internal
	! --------
	real, allocatable :: pc(:,:)
	real :: dpc(size(varrec,2)), amp(size(varrec,2))
	integer :: nt, iphase
	real :: angles(np), projection(size(varrec,2))
	real :: pi, deltarad, pcos, psin, zoffset, zfirstphase
	logical :: select_amplitude(size(varrec,2)), &
	 &         select_phase(size(varrec,2))
	integer :: itime(size(varrec,2)), nsel, i, ns
	integer, allocatable :: isel(:)

	! Setup
	! =====
	nt = size(varrec,2)
	pi = acos(-1.)
	itime = (/ (i, i=1, nt) /)
	ns = size(varrec, 1)
	if(present(offset))then
		zoffset=offset
	else
		zoffset=0.
	end if

	! Find the first PC and its derivative
	! ====================================
	allocate(pc(nt,1))
	call sl_pca(varrec, 1, pc=pc, weights=weights)
	pc = pc * sqrt(real(nt)/sum(pc**2))
	dpc = 0.5 * (eoshift(pc(:,1),  1, pc(nt,1)) - &
	 &           eoshift(pc(:,1), -1, pc(1,1)))
	dpc((/1,nt/)) = dpc((/1,nt/)) * 2.
	dpc = dpc * sqrt(real(nt)/sum(dpc**2))
	amp = sqrt(pc(:,1)**2 + dpc**2)

	! Compute the maps
	! ================

	! Define the marks
	! ----------------
	deltarad = 2 * pi / real(np)
	if(present(firstphase))then
		zfirstphase = modulo(firstphase * 2 * pi / 360., 2 * pi)
	else
	   zfirstphase = 0.
	end if
	angles = (/ (real(iphase), iphase=0,np-1) /) * deltarad + &
	 &       zfirstphase

	! Compute the phase maps
	! ----------------------
	phases = 0.
	select_amplitude = amp >= zoffset
	do iphase = 1, np
		pcos = cos(angles(iphase))
		psin = sin(angles(iphase))
		projection =  (pc(:,1)*pcos+dpc*psin) / amp
		select_phase = ( projection >= cos(0.5*deltarad) ) &
		 &             .and. select_amplitude
		if(any(select_phase))then
			nsel = count(select_phase)
			allocate(isel(nsel))
			isel = pack(itime, select_phase)
			phases(:,iphase) = sum(varrec(:,isel), dim=2) / &
				& real(nsel)
			deallocate(isel)
		end if
	end do

	end subroutine sl_phasecomp

end module spanlib


program problem5
  use euler
  implicit none
  integer*8 :: i,n=1
  integer   :: limit=20

  do i=2,limit
     n=n*(i/gcd(i,n))
  end do
  print *, n

end program problem5


!---------------------------------------------------------------------------
! Description:
!   FFT library with subroutines for 1D FFT, 2D FFT (master), N-dimensional slave FFT.
!   Auxillary subroutines for writing files of fourier transform and zero padding
!
! Method:
!   Followed Daniel Lanczos algorithm as given in Numerical Recipies
!
! Developer: Ashwin Vishnu M
!   Creative Commons (c) 2013
!
! Info:
!   Only +ve frequency range calculated by master subroutines.
!   Sizes of Input matrix (MxN), Output matrix (M/2 x N/2)
!   FFT calculated till Nyquist limit freq = pi/h
!   Least count of frequency spectrum      = pi/(M/2*h)
!---------------------------------------------------------------------------

      subroutine FFT1d(func, M,  transform)    ! Master subroutine
        integer :: Ndim, i, M, zeropadreq
        integer, dimension (1) :: NN
        double precision:: func(M), transform(M/2)
        double precision, dimension(:),allocatable :: data
        double precision :: theta, pi
        double complex ::  Fr, Fi, Ftrans, W, Wp, Hpos, Hneg

        allocate( data(1:2*M) )
        Ndim = 1

         do i= 1,M
            data(2*i-1) = func(i)
            data(2*i  ) = 0d0
         enddo

        NN(1) = M
        print*, 'Starting FFT... '
        call FOURN(data,NN,Ndim,+1)                ! Call slave
        print*, 'FFT Completed... '

        pi=4d0*datan(1d0)
        theta = 2d0*pi/M
        Wp   = dcmplx(dcos(theta),dsin(theta))
        W    = Wp

        Fr = data(1)+data(2)
        Fi = data(1)-data(2)
        Ftrans = Fr - Fi*dcmplx(0.0,1.0)
        transform(1) =Fr !dsqrt(dreal(Ftrans)**2+ dimag(Ftrans)**2)
        do i= 2, M/2
            Hpos =  dcmplx(data(2*i-1), data(2*i))
            Hneg =  dcmplx(data(2*M-2*i+3), data(2*M-2*i+4))
            Fr   =  (Hpos +dconjg(Hneg))  /2d0
            Fi   =  (Hpos -dconjg(Hneg))  /2d0 * W
            Ftrans = Fr - Fi*dcmplx(0.0,1.0)
            transform(i) =dsqrt(dreal(Ftrans)**2+ dimag(Ftrans)**2)
            W = W*Wp
        enddo

        transform = transform*2d0 / M       !Normalization

        deallocate(data)
      endsubroutine FFT1d

      subroutine InvFFT1d(transform, M, func)    ! Master subroutine
        integer :: Ndim, i, M, zeropadreq
        integer, dimension (1) :: NN
        double precision:: func(M), transform(M/2)
        double precision, dimension(:),allocatable :: data
        double precision :: theta, pi
        double complex ::  Fr, Fi, Ftrans, W, Wp, Hpos, Hneg

        allocate( data(1:2*M) )
        Ndim = 1

        data(1)=0.5d0*transform(1)
        data(2)=0d0
        do i= 2,M/2
           data(2*i-1) = 0.5d0*transform(i)
           data(2*i  ) = 0d0
           data(2*M-2*i+3) = 0.5d0*transform(i)
           data(2*M-2*i+4) = 0d0
        enddo

        NN(1) =M

        print*, 'Starting Inverse FFT... '
        call FOURN(data,NN,Ndim,-1)                ! Call slave
        print*, 'Inverse FFT Completed... '

        do i= 1,M
            func(i) = dsqrt(data(2*i-1)**2 + data(2*i)**2)
        enddo

        deallocate(data)
      endsubroutine InvFFT1d

      subroutine FFT2d(func, M, N, transform)    ! Master subroutine
        implicit none
        integer :: Ndim, i, j, M, N, zeropadreq
        integer, dimension (2) :: NN
        double precision:: func(M,N) , transform(M/2,N/2)
        double precision, dimension(:,:),allocatable :: data
        double precision :: theta, pi
        integer :: ipos, jpos, ineg, jneg
        double complex ::  Fr, Fi, Ftrans, W, Wp, Hpos, Hneg

        allocate( data(1:2*M,1:N) )
        Ndim = 2

        do j= 1,N
         do i= 1,M
            data(2*i-1,j) = func(i,j)
            data(2*i, j ) = 0d0
         enddo
        enddo

        NN(1) = M; NN(2) = N
        print*, 'Starting FFT... '
        call FOURN(data,NN,Ndim,+1)                ! Call slave
        print*, 'FFT Completed... '

        pi    = 4d0*datan(1d0)
        theta = 2d0*pi/M
        Wp   = dcmplx(dcos(theta),dsin(theta))
        transform = 0d0

        W = dcmplx(1.0,0.0)
        do i= 1, M/2
          ipos  =  2*i
          ineg  =  2*M-2*i+4
          if(i==1) then
                  ipos = 2
                  ineg = 2
          endif
          do j=1,N/2
            jpos  =  j
            jneg  =  N-j+2
            if(j==1) then
                    jpos = 1
                    jneg = 1
            endif
            Hpos =  dcmplx(data(ipos-1,jpos), data(ipos,jpos))
            Hneg =  dcmplx(data(ineg-1,jneg), data(ineg,jneg))
            Fr   =  (Hpos +conjg(Hneg))  /2d0
            Fi   =  (Hpos -conjg(Hneg))  /2d0 * W
            Ftrans = Fr - Fi*dcmplx(0.0,1.0)
            transform(i,j) =dsqrt(dreal(Ftrans)**2 + dimag(Ftrans)**2)
          enddo
          W = W*Wp
        enddo
        transform = transform*2d0/(M*N)

        deallocate(data)
      endsubroutine FFT2d

!*************************************************************************************!
!            File writing and zeropadding                                             !
!*************************************************************************************!
subroutine WriteFFT1d(transform,M,h,filename)
      implicit none
      integer :: M ,i
      double precision :: transform(M/2), h, k, pi
      character(50) :: filename

      pi = 4d0*datan(1d0)
      open(34, file=trim(filename))
      write(34,*) 'Variables= kh,u_fft'
      write(34,*) 'Zone i=',M/2

      do i=1,M/2
         k = (i-1)*2d0*pi/(M*h)*h
         write(34,*) k, transform(i)
      enddo
      close(34)
endsubroutine WriteFFT1d

subroutine WriteFFT2d(transform,M,N,hx,hy,filename)
      implicit none
      integer :: M,N ,i,j
      double precision :: transform(M/2, N/2), hx,hy, kx, ky, pi
      character(50) :: filename

      pi = 4d0*datan(1d0)
      open(34, file=trim(filename))
      write(34,*) 'Variables= kx,ky,u_fft'
      write(34,*) 'Zone i=',M/2,' j=', N/2

      do j=1,N/2
        ky = (j-1)*2d0*pi/(N*hy)
        do i=1,M/2
         kx = (i-1)*2d0*pi/(M*hx)
         write(34,*) kx,ky, transform(i,j)
        enddo
      enddo
      close(34)
endsubroutine WriteFFT2d

subroutine ZeroPad1d(data,M, datanew,Mpad)
     implicit none
     integer :: M,Mpad, i, ii
     double precision :: data(1:M), pow, datanew(1:Mpad)

     pow = log(real(M))/log(2.0)
     if( mod(pow,1.0) > 0 ) then
        print*, 'Zero padding... ',M,'-->',Mpad
        print*, 'Normalization factor: ', real(Mpad)/M
        ii = -(Mpad-M)/2
        do i = 1,Mpad
           if(ii .ge. 1 .and. ii .le. M ) then
               datanew(i) = data(ii)
           else
               datanew(i) = 0d0
           endif
           ii = ii+1
        enddo

     else
        print*, 'Zero padding not required '
        datanew(1:M) = data(1:M)
     endif
endsubroutine ZeroPad1d

subroutine ZeroPad2d(data,M,N, datanew,Mpad,Npad)
     implicit none
     integer :: M,Mpad, i, ii, N,Npad, j, jj
     double precision :: data(1:M,1:N), pow1, pow2, datanew(1:Mpad,1:Npad)

     pow1 = log(real(M))/log(2.0)
     pow2 = log(real(N))/log(2.0)
     datanew = 0d0

     if( mod(pow1,1.0) > 0 .or. mod(pow2,1.0)>0 ) then
        print*, 'Zero padding...',M,'x',N,'-->',Mpad,'x',Npad
        print*, 'Normalization factor x: ', real(Mpad)/M
        print*, 'Normalization factor y: ', real(Npad)/N

        jj = -(Npad-N)/2
        do  j=1,Npad
         if(jj .ge. 1 .and. jj .le. N ) then
           ii = -(Mpad-M)/2
           do i = 1,Mpad
           if(ii .ge. 1 .and. ii .le. M )then
             datanew(i,j) = data(ii,jj)
           endif
           ii = ii+1
           enddo
         endif
         jj = jj+1
        enddo

     else
        print*, 'Zero padding not required '
        datanew(1:M,1:N) = data(1:M,1:N)
     endif
endsubroutine ZeroPad2d

!*************************************************************************************!
!             Dealiasing for product terms                                            !
!*************************************************************************************!
subroutine Dealias1d(func,func_sq, M)
        integer :: M, i,j,k, ii, zpadindex
        double precision, dimension( 1:M ) :: func
        double precision, dimension(1:M/2) :: transform
        double precision, dimension(1:M) :: convolution, func_sq
        double precision, dimension(1:2*M) :: func_temp
        double precision :: temp, pi, c
        real :: zpad

        pi = 4d0*datan(1d0)
        call FFT1d(func, M, transform)

     ! Convolution Four(f.g) = F(k)*G(k) = Sum(F(k').G(k-k'))
        convolution = 0d0
        do i=1,M
           do j=1,M/2
              k =  i-j+1
              c=0.5d0           ! c to compensate for negative half of the transform
              if(k<1) then
                    c=1d0
                    k = -k+2
              endif
              convolution(i) = convolution(i)+ transform(j)*transform(k)*c
           enddo
        enddo

      ! Zeropadding
        zpad = 2  ! 3/2 k_m or 2 k_m
        convolution(int(zpad*M/4)+1:M) =0d0

!      call writefft1d(convolution,2*M,6d0/(2*M-1),'afterzeropad.dat')

       call InvFFT1d(convolution,2*M,func_temp)
       do i=1,M
         func_sq(i) = func_temp(2*i-1)
       enddo

endsubroutine Dealias1d

subroutine ShiftAlign(func,func_sq,M)
        implicit none
        integer :: M
        integer :: i,ip,im, peak
        double precision, dimension(M):: func, func_sq, temp

        peak = maxloc(func,1)

        temp(peak) = func_sq(1)

        ip = peak+1
        im = peak-1
        do i = 2, M/2
            if(ip == M) then          !When Periodic B.C. is applied
                   temp(ip)=func_sq(i)
                   ip=1
            endif
            if(im == 1) then
                   temp(im)=func_sq(i)
                   im=M
            endif
            temp(ip) = func_sq(i)
            temp(im) = func_sq(i)
            ip = ip+1
            im = im-1
        enddo
        func_sq = temp
endsubroutine ShiftAlign

!*************************************************************************************!
!             Slave subroutine by N.Brenner. Ref: Numerical recipies                  !
!*************************************************************************************!
      subroutine FOURN(data, NN, Ndim, ISIGN)
         implicit none
         integer :: Ndim, ISIGN                  ! No of dimensions,ISIGN= +1 FFT, -1 Inv FFT
         double precision, dimension(*) :: data  ! I/P and transformed O/P data array
         integer, dimension(Ndim) :: NN          ! No of sampled points in each dimension
         double complex :: W, Wp, Wtemp, temp
         double precision :: theta, pi
         integer :: N, Ntot, Nprev, Nrem
         integer :: i1, i2, i2rev, i3, i3rev, ip1, ip2, ip3,idim, ibit
         integer :: k1, k2, ifp1, ifp2

         pi= 4d0*datan(1d0)
         Ntot = 1     ! Count total no. of data
         do idim = 1, Ndim
           Ntot = Ntot * NN(idim)
         enddo
         Nprev=1

         do idim = 1, Ndim   ! Loop over dimensions
           N = NN(idim)
           print*, 'Sweeping along dimension #',idim, N, 'points'
           Nrem =  Ntot /(N*Nprev)

           ip1 = Nprev*2
           ip2 = ip1*N
           ip3 = ip2*Nrem
           i2rev= 1

           !******* BIT REVERSAL ********!
           do i2 = 1, ip2, ip1
                if(i2 .lt. i2rev) then
                  do i1 = i2, i2+ip1-2, 2
                   do i3 = i1,ip3,ip2
                       i3rev = i2rev + i3 - i2
                       call swap(data(i3), data(i3rev))
                       call swap(data(i3+1), data(i3rev+1))
                   enddo
                  enddo
                 endif

                 ibit=ip2/2
                 do while( (ibit .ge. ip1) .and. (i2rev .gt. ibit))
                       i2rev=i2rev-ibit
                       ibit=ibit/2
                 enddo
                 i2rev = i2rev + ibit
           enddo

           !****** DANIELSON LANCZOS ALGO FOR FFT****!
           ifp1=ip1
           do while(ifp1 .lt. ip2)
                ifp2=2*ifp1
                theta= ISIGN*2d0*pi/(ifp2/ip1)
                Wp = dcmplx( -2d0*dsin(0.5d0*theta)**2, dsin(theta))
                W  = dcmplx( 1d0 ,0 )
                do i3=1, ifp1, ip1
                 do i1=i3,i3+ip1-2 ,2
                  do i2=i1,ip3,ifp2
                      k1 = i2
                      k2 = k1+ifp1
                      temp = W*dcmplx(data(k2), data(k2+1))
                      data(k2)   = data(k1)   -dreal(temp)
                      data(k2+1) = data(k1+1) -dimag(temp)
                      data(k1)   = data(k1)   +dreal(temp)
                      data(k1+1) = data(k1+1) +dimag(temp)
                   enddo
                  enddo
                  W = W*Wp + W
                enddo
               ifp1=ifp2
           enddo
           Nprev = N*Nprev
         enddo
      endsubroutine FOURN

      subroutine swap(a,b)
        implicit none
        double precision :: a,b
        double precision :: temp
             temp = a
             a = b
             b = temp
      endsubroutine swap

      subroutine nextpower(N1,N2)
       implicit none
       real :: pow
       integer:: N1, N2

       pow = log(real(N1))/log(2.0)

       if( mod(pow,1.0) > 0.0) then
         pow = pow+1.0
         N2 = 2**int(pow)
       else
         N2 = N1
       endif
      endsubroutine nextpower


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

module dewpoint_obs_err_mod

use        types_mod, only : r8
use       meteor_mod, only : rh_and_temp_to_dewpoint, temp_and_dewpoint_to_rh

implicit none
private

public :: dewpt_error_from_rh_and_temp, rh_error_from_dewpt_and_temp

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   dewpt_error_from_rh_and_temp - computes estimated uncertainty in
!           a dewpoint observation, when the dewpoint is derived from
!           temperature and relative humidity observations
!
!     created Dec. 2008 David Dowell, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function dewpt_error_from_rh_and_temp(tmpk, rh_in)

! reference:  Lin and Hubbard 2004, Journal of Applied Meteorology, 821-825

real(r8)             :: dewpt_error_from_rh_and_temp
real(r8), intent(in) :: tmpk                   ! temperature (Kelvin)
real(r8), intent(in) :: rh_in                  ! relative humidity (0.00-1.00)

real(r8), parameter  :: rh_error = 0.05_r8     ! guess for instrument + representativeness error
real(r8), parameter  :: t_error = 1.0_r8       ! guess for instrument + representativeness error

real(r8), parameter  :: rh_min = 0.20_r8
real(r8), parameter  :: rh_max = 1.00_r8
real(r8), parameter  :: delta_rh = 0.01_r8     ! perturbation for finite differencing
real(r8), parameter  :: delta_t  = 0.1_r8      ! perturbation for finite differencing
real(r8)             :: rh
real(r8)             :: rh1
real(r8)             :: rh2
real(r8)             :: t1
real(r8)             :: t2
real(r8)             :: td_deriv_rh
real(r8)             :: td_deriv_t

if ( ( rh_in < 0.00_r8 ) .or. ( rh_in > 1.00_r8 ) ) then
  print*,'dewpt_error_from_rh_and_temp:  bad rh ',rh_in
  stop
end if

! The uncertainty in dewpoint derived from temperature and relative humidity grows without bound
! as the relative humidity approaches 0.  A lower bound on the input relative humidity will be
! applied to keep the calculation bounded and to acknowledge uncertainty in the relative humidity
! measurement.

rh = max(rh_in, rh_min)

! finite-difference approximations of derivatives
rh1 = max(rh - delta_rh, rh_min)
rh2 = min(rh + delta_rh, rh_max)
t1 = tmpk - delta_t
t2 = tmpk + delta_t
td_deriv_rh = ( rh_and_temp_to_dewpoint(rh2, tmpk) - rh_and_temp_to_dewpoint(rh1, tmpk) ) / (rh2-rh1)
td_deriv_t = ( rh_and_temp_to_dewpoint(rh, t2) - rh_and_temp_to_dewpoint(rh, t1) ) / (t2-t1)

dewpt_error_from_rh_and_temp = sqrt ( td_deriv_t*td_deriv_t * t_error*t_error &
                                     +td_deriv_rh*td_deriv_rh * rh_error*rh_error)

return
end function dewpt_error_from_rh_and_temp

! GSR  - Added rh error function following above
function rh_error_from_dewpt_and_temp(tmpk, dewpt)

! reference:  Lin and Hubbard 2004, Journal of Applied Meteorology, 821-825

real(r8)             :: rh_error_from_dewpt_and_temp
real(r8), intent(in) :: tmpk                   ! temperature (Kelvin)
real(r8), intent(in) :: dewpt                  ! dewpoint temperature (Kelvin)

real(r8), parameter  :: td_error = 1.50_r8     ! guess for instrument + representativeness error
real(r8), parameter  :: t_error = 1.0_r8       ! guess for instrument + representativeness error

real(r8), parameter  :: delta_td = 0.1_r8      ! perturbation for finite differencing
real(r8), parameter  :: delta_t  = 0.1_r8      ! perturbation for finite differencing
real(r8)             :: td1
real(r8)             :: td2
real(r8)             :: t1
real(r8)             :: t2
real(r8)             :: rh_deriv_td
real(r8)             :: rh_deriv_t

if ( ( dewpt > tmpk ) ) then
  print*,'rh_error_from_dewpt_and_temp:  bad dewpt ',dewpt, tmpk
  stop
end if

! finite-difference approximations of derivatives
td1 = dewpt - delta_td
td2 = min (dewpt + delta_td, tmpk + delta_t)
t1 = tmpk - delta_t
t2 = tmpk + delta_t
rh_deriv_td = ( temp_and_dewpoint_to_rh(tmpk, td2) - temp_and_dewpoint_to_rh(tmpk, td1) ) / (td2-td1)
rh_deriv_t = ( temp_and_dewpoint_to_rh(t2, dewpt) - temp_and_dewpoint_to_rh(t1, dewpt) ) / (t2-t1)

rh_error_from_dewpt_and_temp = sqrt ( rh_deriv_t*rh_deriv_t * t_error*t_error &
                                     +rh_deriv_td*rh_deriv_td * td_error*td_error)

return
end function rh_error_from_dewpt_and_temp

end module dewpoint_obs_err_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


	PROGRAM PREAMP
C
C	THIS PROGRAM CALCULATES THE ELECTRIC PREAMP RESPONSE,
C	WITH (ICOMP=1)  OR WITHOUT (ICOMP=0) COMPENSATION FILTER
C	IT WRITES A FILE FOR011.DAT TO BE PLOTTED BY MONGO
C
	COMPLEX Z1,Z2,Z3,Z4,Y1,Y2,VIN,VAC,VDC,V1,V2,V3
	DATA ICOMP /0/
	DATA C9 /22.E-12/
	DATA R9,R10 /5.E8,5.E8/
	DATA R33 /1.E4/
	DATA C16 /1.E-8/
	DATA C12,C13,C15/15.E-9,4.7E-9,180.E-12/
	DATA R28,R29,R32 /1.E5, 1.2E3, 2.2E3/
	DATA R2C,C2C /4.64E3,1.E-6/
	DATA TWOPI /6.2831853/
	DATA FHZMIN,FHZMAX,NF /1.,200.E3,120/
C
	FRAT = ALOG(FHZMAX/FHZMIN)/(NF-1)
	FRAT = EXP(FRAT)
	FHZ = FHZMIN
	VIN = 1.
	DO 100 NN = 1,NF
	W = TWOPI*FHZ
C
C	GAIN OF THE INPUT CIRCUIT, BEFORE Q1
C
	Y1 = CMPLX(1./R9, W*C9)
	Z1 = 1./Y1
	V1 = VIN*R10/(R10 + Z1)
C
C	GAIN OF THE DC OUTPUT
C
	Z1 = CMPLX(R33,-1./W/C16)
	Z2 = CMPLX(0.,-1./W/C16)
	VDC = V1*Z2/Z1
C
C	GAIN OF THE OUTPUT CIRCUIT AROUND U2
C	V1 IS THE RELAY OUTPUT
C
	Z1 = CMPLX(R28,-1./(W*C12))
C	V2 IS THE INPUT AT PIN 3 OF U2
	V2 = V1*R28/Z1
C	V3 IS THE OUTPUT VOLTAGE AT PIN 6 OF U2
	Y1 = CMPLX(1./R32,W*C15)
	Z1 = 1./Y1
	Z2 = CMPLX(R29,-1./W/C13)
	V3 = V2*(Z2 + Z1)/Z2
	IF(ICOMP.NE.0) THEN
C
C	  COMPENSATION NETWORK FOR INPUT CIRCUIT, CONSISTING OF
C	  R1C IN SERIES WITH R2C AND C2C
C
	  V2 = VDC
	  Z1 = CMPLX(R2C,-1./W/C2C)
	  Z2 = CMPLX(R1C,0.)
	  VDC = V2*Z1/(Z2 + Z1)
	ENDIF
C
C	WRITE OUTPUT FILE
C
	VAC = V3
	GAINAC = CABS(VAC)
	VR = VAC
	VI = AIMAG(VAC)
	PHAC = 57.29578*ATAN2(VI,VR)
	GAINDC = CABS(VDC)
	VR = VDC
	VI = AIMAG(VDC)
	PHDC = 57.29578*ATAN2(VI,VR)
C
	WRITE(11,1001) FHZ,VAC,GAINAC,PHAC,VDC,GAINDC,PHDC
 1001	FORMAT(E13.4,3F7.3,F6.1,2X,3F7.3,F6.1)
	PRINT*,FHZ,VAC,GAINAC,PHAC
	FHZ = FHZ*FRAT
 100	CONTINUE
	STOP
	END
	SUBROUTINE MGO
C	THIS IS  PREAMP.MGO
C	STORED HERE FOR REFERENCE--TO BE RUN INTERACTIVELY
C
C	DATA FOR011.DAT
C	FORMAT (E13.4,3F7.3,F6.1,2X,3F7.3,F6.1)
C	XCOLUMN 1
C	XLOGARITHM 1
C	YCOLUMN 4                 ! GAIN AC
C	LIMITS  -0.5  6.   0.  4.
C	CONNECT
C	BOX
C	XCOLUMN 1
C	XLOGARITHM 1
C	YCOLUMN 8                 ! GAIN DC
C	LIMITS 0.  6.  0.  5.
C	CONNECT
C	XLABEL LOG FREQUENCY (HZ)
C	YLABEL GAIN
C	ID
	RETURN
	END


      SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE,
     $                   NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To extract from the (N+P)-by-(M+N) descriptor system pencil
C
C        S(lambda) = ( B   A - lambda*E  )
C                    ( D        C        )
C
C     with E nonsingular and upper triangular a
C     (NR+PR)-by-(M+NR) "reduced" descriptor system pencil
C
C                           ( Br  Ar-lambda*Er )
C              Sr(lambda) = (                  )
C                           ( Dr     Cr        )
C
C     having the same finite Smith zeros as the pencil
C     S(lambda) but with Dr, a PR-by-M full row rank
C     left upper trapezoidal matrix, and Er, an NR-by-NR
C     upper triangular nonsingular matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FIRST   LOGICAL
C             Specifies if AG08BY is called first time or it is called
C             for an already reduced system, with D full column rank
C             with the last M rows in upper triangular form:
C             FIRST = .TRUE.,  first time called;
C             FIRST = .FALSE., not first time called.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of matrix B, the number of columns of
C             matrix C and the order of square matrices A and E.
C             N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrices B and D.  M >= 0.
C             M <= P if FIRST = .FALSE. .
C
C     P       (input) INTEGER
C             The number of rows of matrices C and D.  P >= 0.
C
C     SVLMAX  (input) DOUBLE PRECISION
C             During each reduction step, the rank-revealing QR
C             factorization of a matrix stops when the estimated minimum
C             singular value is smaller than TOL * MAX(SVLMAX,EMSV),
C             where EMSV is the estimated maximum singular value.
C             SVLMAX >= 0.
C
C     ABCD    (input/output) DOUBLE PRECISION array, dimension
C             (LDABCD,M+N)
C             On entry, the leading (N+P)-by-(M+N) part of this array
C             must contain the compound matrix
C                      (  B   A  ) ,
C                      (  D   C  )
C             where A is an N-by-N matrix, B is an N-by-M matrix,
C             C is a P-by-N matrix and D is a P-by-M matrix.
C             If FIRST = .FALSE., then D must be a full column
C             rank matrix with the last M rows in upper triangular form.
C             On exit, the leading (NR+PR)-by-(M+NR) part of ABCD
C             contains the reduced compound matrix
C                       (  Br  Ar ) ,
C                       (  Dr  Cr )
C             where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix,
C             Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank
C             left upper trapezoidal matrix with the first PR columns
C             in upper triangular form.
C
C     LDABCD  INTEGER
C             The leading dimension of array ABCD.
C             LDABCD >= MAX(1,N+P).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper triangular nonsingular matrix E.
C             On exit, the leading NR-by-NR part contains the reduced
C             upper triangular nonsingular matrix Er.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     NR      (output) INTEGER
C             The order of the reduced matrices Ar and Er; also the
C             number of rows of the reduced matrix Br and the number
C             of columns of the reduced matrix Cr.
C             If Dr is invertible, NR is also the number of finite
C             Smith zeros.
C
C     PR      (output) INTEGER
C             The rank of the resulting matrix Dr; also the number of
C             rows of reduced matrices Cr and Dr.
C
C     NINFZ   (output) INTEGER
C             Number of infinite zeros.  NINFZ = 0 if FIRST = .FALSE. .
C
C     DINFZ   (output) INTEGER
C             The maximal multiplicity of infinite zeros.
C             DINFZ = 0 if FIRST = .FALSE. .
C
C     NKRONL  (output) INTEGER
C             The maximal dimension of left elementary Kronecker blocks.
C
C     INFZ    (output) INTEGER array, dimension (N)
C             INFZ(i) contains the number of infinite zeros of
C             degree i, where i = 1,2,...,DINFZ.
C             INFZ is not referenced if FIRST = .FALSE. .
C
C     KRONL   (output) INTEGER array, dimension (N+1)
C             KRONL(i) contains the number of left elementary Kronecker
C             blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             If the user sets TOL <= 0, then an implicitly computed,
C             default tolerance TOLDEF = (N+P)*(N+M)*EPS,  is used
C             instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH).
C             NOTE that when SVLMAX > 0, the estimated ranks could be
C             less than those defined above (see SVLMAX).  TOL <= 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C             If FIRST = .FALSE., IWORK is not referenced.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1, if P = 0; otherwise
C             LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ),
C                                             if FIRST = .TRUE.;
C             LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. .
C             The second term is not needed if M = 0.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The subroutine is based on the reduction algorithm of [1].
C
C     REFERENCES
C
C     [1] P. Misra, P. Van Dooren and A. Varga.
C         Computation of structural invariants of generalized
C         state-space systems.
C         Automatica, 30, pp. 1921-1936, 1994.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( (P+N)*(M+N)*N )  floating point operations.
C
C     FURTHER COMMENTS
C
C     The number of infinite zeros is computed as
C
C                   DINFZ
C        NINFZ =     Sum  (INFZ(i)*i) .
C                    i=1
C     Note that each infinite zero of multiplicity k corresponds to
C     an infinite eigenvalue of multiplicity k+1.
C     The multiplicities of the infinite eigenvalues can be determined
C     from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows:
C
C                     DINFZ
C     - there are PR - Sum (INFZ(i)) simple infinite eigenvalues;
C                      i=1
C
C     - there are INFZ(i) infinite eigenvalues with multiplicity i+1,
C       for i = 1, ..., DINFZ.
C
C     The left Kronecker indices are:
C
C     [ 0  0 ...  0  | 1  1  ...  1 |  .... | NKRONL  ...  NKRONL ]
C     |<- KRONL(1) ->|<- KRONL(2) ->|       |<-  KRONL(NKRONL)  ->|
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     May 1999. Based on the RASP routine SRISEP.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999,
C     Jan. 2009, Apr. 2009.
C     A. Varga, DLR Oberpfaffenhofen, March 2002.
C     V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion.
C     V. Sima, Apr. 2011.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER            DINFZ, INFO, LDABCD, LDE, LDWORK, M, N, NINFZ,
     $                   NKRONL, NR, P, PR
      DOUBLE PRECISION   SVLMAX, TOL
      LOGICAL            FIRST
C     .. Array Arguments ..
      INTEGER            INFZ( * ), IWORK(*), KRONL( * )
      DOUBLE PRECISION   ABCD( LDABCD, * ), DWORK( * ), E( LDE, * )
C     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU,
     $                   J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR,
     $                   MNTAU, MP1, MPM, MUI, MUIM1, N1, NBLCKS, PN,
     $                   RANK, RO, RO1, SIGMA, TAUI, WRKOPT
      DOUBLE PRECISION   C, C1, C2, RCOND, S, S1, S2, SMAX, SMAXPR,
     $                   SMIN, SMINPR, T, TOLZ, TT
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1), SVAL(3)
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DNRM2
      EXTERNAL           DLAMCH, DNRM2, IDAMAX
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAIC1, DLAPMT, DLARFG, DLARTG, DLASET,
     $                   DLATZM, DORMQR, DROT, DSWAP, MB03OY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      LQUERY = ( LDWORK.EQ.-1 )
      INFO = 0
      PN   = P + N
      MN   = M + N
      MPM  = MIN( P, M )
      IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -5
      ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN
         INFO = -7
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( TOL.GT.ONE ) THEN
         INFO = -17
      ELSE
         WRKOPT = MAX( 1, 5*P )
         IF( P.GT.0 ) THEN
            IF( M.GT.0 ) THEN
               WRKOPT = MAX( WRKOPT, MN-1 )
               IF( FIRST ) THEN
                  WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) )
                  IF( LQUERY ) THEN
                     CALL DORMQR( 'Left', 'Transpose', P, N, MPM, ABCD,
     $                            LDABCD, DWORK, ABCD, LDABCD, DWORK,
     $                            -1, INFO )
                     WRKOPT = MAX( WRKOPT, MPM + INT( DWORK(1) ) )
                  END IF
               END IF
            END IF
         END IF
         IF( LDWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN
            INFO = -20
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'AG08BY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Initialize output variables.
C
      PR = P
      NR = N
      DINFZ  = 0
      NINFZ  = 0
      NKRONL = 0
C
C     Quick return if possible.
C
      IF( P.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
      IF( N.EQ.0 .AND. M.EQ.0 ) THEN
         PR = 0
         NKRONL   = 1
         KRONL(1) = P
         DWORK(1) = ONE
         RETURN
      END IF
C
      TOLZ  = SQRT( DLAMCH( 'Epsilon' ) )
      RCOND = TOL
      IF( RCOND.LE.ZERO ) THEN
C
C        Use the default tolerance in rank determination.
C
         RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' )
      END IF
C
C     The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and
C     SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE..
C     The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column
C     rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular.
C
      IF( FIRST ) THEN
         SIGMA = 0
      ELSE
         SIGMA = M
      END IF
      RO  = P - SIGMA
      MP1 = M + 1
      MUI = 0
      DUM(1) = ZERO
C
      ITAU   = 1
      JWORK1 = ITAU + MPM
      ISMIN  = 2*P + 1
      ISMAX  = ISMIN + P
      JWORK2 = ISMAX + P
      NBLCKS = 0
      WRKOPT = 1
C
   10 IF( PR.EQ.0 ) GO TO 90
C
C     (NR+1,ICOL+1) points to the current position of matrix D.
C
      RO1 = RO
      MNR = M + NR
      IF( M.GT.0 ) THEN
C
C        Compress rows of D; first exploit the trapezoidal shape of the
C        (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D;
C        compress the first SIGMA columns without column pivoting:
C
C              ( x x x x x )       ( x x x x x )
C              ( x x x x x )       ( 0 x x x x )
C              ( x x x x x )  - >  ( 0 0 x x x )
C              ( 0 x x x x )       ( 0 0 0 x x )
C              ( 0 0 x x x )       ( 0 0 0 x x )
C
C        where SIGMA = 3 and RO = 2.
C        Workspace: need maximum M+N-1.
C
         IROW = NR
         DO 20 ICOL = 1, SIGMA
            IROW = IROW + 1
            CALL DLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1,
     $                   T )
            CALL DLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, T,
     $                   ABCD(IROW,ICOL+1), ABCD(IROW+1,ICOL+1),
     $                   LDABCD, DWORK )
            CALL DCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 )
   20    CONTINUE
         WRKOPT = MAX( WRKOPT, MN - 1 )
C
         IF( FIRST ) THEN
C
C           Continue with Householder with column pivoting.
C
C              ( x x x x x )        ( x x x x x )
C              ( 0 x x x x )        ( 0 x x x x )
C              ( 0 0 x x x )  - >   ( 0 0 x x x )
C              ( 0 0 0 x x )        ( 0 0 0 x x )
C              ( 0 0 0 x x )        ( 0 0 0 0 0 )
C
C           Real workspace:    need maximum min(P,M)+3*M-1;
C           Integer workspace: need maximum M.
C
            IROW = MIN( NR+SIGMA+1, PN )
            ICOL = MIN( SIGMA+1, M )
            CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD,
     $                   RCOND, SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU),
     $                   DWORK(JWORK1), INFO )
            WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 )
C
C           Apply the column permutations to B and part of D.
C
            CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL),
     $                   LDABCD, IWORK )
C
            IF( RANK.GT.0 ) THEN
C
C              Apply the Householder transformations to the submatrix C.
C              Workspace: need   maximum min(P,M) + N;
C                         prefer maximum min(P,M) + N*NB.
C
               CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK,
     $                      ABCD(IROW,ICOL), LDABCD, DWORK(ITAU),
     $                      ABCD(IROW,MP1), LDABCD, DWORK(JWORK1),
     $                      LDWORK-JWORK1+1, INFO )
               WRKOPT = MAX( WRKOPT, JWORK1 + INT( DWORK(JWORK1) ) - 1 )
               CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO,
     $                      ZERO, ABCD(MIN( IROW+1, PN ),ICOL), LDABCD )
               RO1 = RO1 - RANK
            END IF
         END IF
C
C        Terminate if Dr has maximal row rank.
C
         IF( RO1.EQ.0 ) GO TO 90
C
      END IF
C
C     Update SIGMA.
C
      SIGMA = PR - RO1
C
      NBLCKS = NBLCKS + 1
      TAUI = RO1
C
C     Compress the columns of current C to separate a TAUI-by-MUI
C     full column rank block.
C
      IF( NR.EQ.0 ) THEN
C
C        Finish for zero state dimension.
C
         PR = SIGMA
         RANK = 0
      ELSE
C
C        Perform RQ-decomposition with row pivoting on the current C
C        while keeping E upper triangular.
C        The current C is the TAUI-by-NR matrix delimited by rows
C        IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD.
C        The rank of current C is computed in MUI.
C        Workspace: need maximum 5*P.
C
         IRC = NR + SIGMA
         N1  = NR
         IF( TAUI.GT.1 ) THEN
C
C           Compute norms.
C
            DO 30 I = 1, TAUI
               DWORK(I) = DNRM2( NR, ABCD(IRC+I,MP1), LDABCD )
               DWORK(P+I) = DWORK(I)
   30       CONTINUE
         END IF
C
         RANK  = 0
         MNTAU = MIN( TAUI, NR )
C
C        ICOL and IROW will point to the current pivot position in C.
C
         ILAST = NR + PR
         JLAST = M  + NR
         IROW = ILAST
         ICOL = JLAST
         I = TAUI
   40    IF( RANK.LT.MNTAU ) THEN
            MN1 = M + N1
C
C           Pivot if necessary.
C
            IF( I.NE.1 ) THEN
               J = IDAMAX( I, DWORK, 1 )
               IF( J.NE.I ) THEN
                  DWORK(J) = DWORK(I)
                  DWORK(P+J) = DWORK(P+I)
                  CALL DSWAP( N1, ABCD(IROW,MP1), LDABCD,
     $                        ABCD(IRC+J,MP1), LDABCD )
               END IF
            END IF
C
C           Zero elements left to ABCD(IROW,ICOL).
C
            DO 50 K = 1, N1-1
               J = M + K
C
C              Rotate columns J, J+1 to zero ABCD(IROW,J).
C
               T = ABCD(IROW,J+1)
               CALL DLARTG( T, ABCD(IROW,J), C, S, ABCD(IROW,J+1) )
               ABCD(IROW,J) = ZERO
               CALL DROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S )
               CALL DROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S )
C
C              Rotate rows K, K+1 to zero E(K+1,K).
C
               T = E(K,K)
               CALL DLARTG( T, E(K+1,K), C, S, E(K,K) )
               E(K+1,K) = ZERO
               CALL DROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S )
               CALL DROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD,
     $                    C, S )
   50       CONTINUE
C
            IF( RANK.EQ.0 ) THEN
C
C              Initialize; exit if matrix is zero (RANK = 0).
C
               SMAX = ABS( ABCD(ILAST,JLAST) )
               IF ( SMAX.EQ.ZERO ) GO TO 80
               SMIN   = SMAX
               SMAXPR = SMAX
               SMINPR = SMIN
               C1 = ONE
               C2 = ONE
            ELSE
C
C              One step of incremental condition estimation.
C
               CALL DCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD,
     $                     DWORK(JWORK2), 1 )
               CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN,
     $                      DWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1,
     $                      C1 )
               CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX,
     $                      DWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2,
     $                      C2 )
               WRKOPT = MAX( WRKOPT, 5*P )
            END IF
C
C           Check the rank; finish the loop if rank loss occurs.
C
            IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
               IF( SVLMAX*RCOND.LE.SMINPR ) THEN
                  IF( SMAXPR*RCOND.LE.SMINPR ) THEN
C
C                    Finish the loop if last row.
C
                     IF( N1.EQ.0 ) THEN
                        RANK = RANK + 1
                        GO TO 80
                     END IF
C
                     IF( N1.GT.1 ) THEN
C
C                       Update norms.
C
                        IF( I-1.GT.1 ) THEN
                           DO 60 J = 1, I - 1
                              IF( DWORK(J).NE.ZERO ) THEN
                                 T = ABS( ABCD(IRC+J,ICOL) ) / DWORK(J)
                                 T = MAX( ( ONE + T )*( ONE - T ), ZERO)
                                 TT = T*( DWORK(J)/DWORK(P+J) )**2
                                 IF( TT.GT.TOLZ ) THEN
                                    DWORK(J) = DWORK(J)*SQRT( T )
                                 ELSE
                                    DWORK(J) = DNRM2( N1-1,
     $                                         ABCD(IRC+J,MP1), LDABCD )
                                    DWORK(P+J) = DWORK(J)
                                 END IF
                              END IF
   60                      CONTINUE
                        END IF
                     END IF
C
                     DO 70 J = 1, RANK
                        DWORK( ISMIN+J-1 ) = S1*DWORK( ISMIN+J-1 )
                        DWORK( ISMAX+J-1 ) = S2*DWORK( ISMAX+J-1 )
   70                CONTINUE
C
                     DWORK( ISMIN+RANK ) = C1
                     DWORK( ISMAX+RANK ) = C2
                     SMIN = SMINPR
                     SMAX = SMAXPR
                     RANK = RANK + 1
                     ICOL = ICOL - 1
                     IROW = IROW - 1
                     N1 = N1 - 1
                     I  = I  - 1
                     GO TO 40
                  END IF
               END IF
            END IF
         END IF
      END IF
C
   80 CONTINUE
      MUI = RANK
      NR  = NR - MUI
      PR  = SIGMA + MUI
C
C     Set number of left Kronecker blocks of order (i-1)-by-i.
C
      KRONL(NBLCKS) = TAUI - MUI
C
C     Set number of infinite divisors of order i-1.
C
      IF( FIRST .AND. NBLCKS.GT.1 )
     $   INFZ(NBLCKS-1) = MUIM1 - TAUI
      MUIM1 = MUI
      RO = MUI
C
C     Continue reduction if rank of current C is positive.
C
      IF( MUI.GT.0 )
     $   GO TO 10
C
C     Determine the maximal degree of infinite zeros and
C     the number of infinite zeros.
C
   90 CONTINUE
      IF( FIRST ) THEN
         IF( MUI.EQ.0 ) THEN
            DINFZ = MAX( 0, NBLCKS - 1 )
         ELSE
            DINFZ = NBLCKS
            INFZ(NBLCKS) = MUI
         END IF
         K = DINFZ
         DO 100 I = K, 1, -1
            IF( INFZ(I).NE.0 ) GO TO 110
            DINFZ = DINFZ - 1
  100    CONTINUE
  110    CONTINUE
         DO 120 I = 1, DINFZ
            NINFZ = NINFZ + INFZ(I)*I
  120    CONTINUE
      END IF
C
C     Determine the maximal order of left elementary Kronecker blocks.
C
      NKRONL = NBLCKS
      DO 130 I = NBLCKS, 1, -1
         IF( KRONL(I).NE.0 ) GO TO 140
         NKRONL = NKRONL - 1
  130 CONTINUE
  140 CONTINUE
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of AG08BY ***
      END