c this code calculate the spectrum of a standard thin disk
c the code is based on the formula in the book "accretion
c power in astrophysics" by Frank et al. 1992
c in unit of cm.g.sec

     	IMPLICIT REAL*8(A-H,O-Z)
        dimension y(4),dy(4),w(16),nu(200),fnu(200)
	common dotm,h,k,mass,rs,solarmass,rin
        double precision mass,nu,k,h,nnu

	call cpu_time(start_time)

	open(20,file='ssd.dat')
	open(14,file='hottem.dat')

	h=6.626d-27
	c=2.9979d+10
	k=1.3807d-16
	pi=3.1416d0
	pc=3.086d+18
	solarmass=1.989d+33

        read(*,*) distance
        distance=distance*pc
c	distance=14.5d6*pc !--------------1-----------------!

        read(*,*) mass
        mass=mass*1.d6*solarmass
c	mass=1.2d8*solarmass !--------------2-----------------!

	g=6.672d-8
	rs=2.*g*mass/c/c
	dotme=1.39d18*mass/solarmass
c note in the above defination, the factor of 0.1 is included
c the unit is g/s

c***********************************
c *** I still did not figure this out. By comparing the output of
c this code with the SSD models in Lasota+96, Quataert+99, Nemmen+06,
c for the same mdot the SSD SEDs there are 10x weaker compared to the
c output of this code. By hand I introduced below a factor 0.1 for
c the correction of mdot. (9/01/2008)
c **********************************
c UPDATE Mar 8th 2012
c Still wondering about the 0.1 factor below
c **********************************
        read(*,*) dotm
        dotm=0.1d0*dotm*dotme
c        dotm=dotm*dotme
c	dotm=6.4d-4*dotme !--------------3-----------------!

        read(*,*) rin
        rin=rin*rs
c	rin=225.d0*rs  !--------------4-----------------!
c	rout=3.0d+4*rs  !--------------5-----------------!

        read(*,*) theta
	theta=theta/57.2958 !--------------6-----------------!
c*********************************
	do 10 i=1,50

c *** Changed the initial frequency from 12. to 11.
	nu(i)=10.d0**(11.+0.1d0*i)

	if(nu(i).lt.1.d16) rout=8.d+4*rs
	if(nu(i).gt.1.d16) rout=1.d+4*rs

	nnu=nu(i)
	s=0.d0
	call simpsn(rin,rout,1.d-3,8000,n,s,nnu)
	write(*,*) i,nu(i),n,s,exp(700.d0)

	fnu(i)=4.*pi*h*cos(theta)*nu(i)**3.d0/c/c*s
c *** Changed the output below to nu*Lnu instead of nu*Fnu
c	write(20,*) log10(nu(i)),log10(nu(i)*fnu(i)/distance**2.)
	write(20,*) log10(nu(i)),log10(nu(i)*fnu(i)*4.*pi)

10	continue

	call cpu_time(finish_time)
	print*,'cpu times=',finish_time-start_time,' seconds'

	end
c=====================================================================c
	function f(x,nu)
	implicit real*8(a-h,o-z)
	dimension reprr(1000),repr(1000),rephh(1000),reph(1000),
     $		emis(1000),tau2(1000)
	common dotm,h,k,mass,rs,solarmass,rin
	double precision mass,nu,k,m8,msun

c	dotm26=dotm/1.d+26*(1.-rin/x)
 	dotm26=dotm/1.d+26

c now consider the reprocessing effect
c all the related quantites such as the location in ADAF, height
c and emissivity are started with 'rep'
c 'n' is the number of the integration zone of ADAF
c reph(i), repr(i): the hieght and radius of a point in ADAF

        repn=11

	msun=1.989d33
        g=6.67d-8
        pi=3.1416d0
c       rs=g*m*1.d6*msun/9.d20

        if(kkrep.eq.0) then

        do 103 i=1,int(repn)
        read(14,*) reprr(i),rephh(i),emis(i),tau2(i)
c emis is in units of cm.g.s
        repr(i)=reprr(i)*rs/2.
        reph(i)=rephh(i)*rs/2.
103     continue

        kkrep=1
        endif

        frep=0.d0
        do 50 i=1,int(repn-1)

c       ff1=reph(i)/2.*pi/(reph(i)*reph(i)/4.+(x-repr(i))**2.d0)**1.5

	ff1=reph(i)/2.*pi/(reph(i)*reph(i)/4.+
     $          (repr(i)*sin(22.5/57.))**2.d0+(x-repr(i))**2.d0)**1.5

        ff2=reph(i)*pi/(reph(i)*reph(i)/4.+repr(i)*repr(i)+x*x)**1.5
        ff3=reph(i)/2.*pi/(reph(i)*reph(i)/4.+(repr(i)+x)**2.d0)**1.5
        frep=frep+0.8d0*emis(i)*(ff1+ff2+ff3)
     $          *(repr(i)-repr(i+1))*repr(i)*reph(i)/exp(tau2(i)*1.0)
c frep: corresponds to fvis, the flux produce per unit area due to
c the reprocessing of the central X-ray source

50      continue

	fvis=3./8./pi*g*mass/x**3.d0*dotm26*1.d26*(1.-(3.*rs/x)**0.5d0)
c	fvis=3./8./pi*g*mass/x**3.d0*dotm26*1.d26

	m8=mass/solarmass/1.d+8
	r14=x/1.d+14
c	tem=2.2d+5*dotm26**0.25d0*m8**0.25d0*r14**(-0.75d0)

	tem=((frep*10.d-1+fvis)/5.67d-5)**0.25d0

c for the above formula, see the first page of Chapter 8 in <<accretion>> book

	if (h*nu/(k*tem).gt.700.) then
 	 f=0.d0
	else
         f=x/(dexp(h*nu/(k*tem))-1.d0)
	endif

	return
	end

c=============================================================c
	subroutine simpsn(a,b,eps,k,n,s,nu)
        implicit real*8(a-h,o-z)
	double precision nu
        n=1
        c=abs(a)+abs(b)
        h=0.5*(b-a)
        t1=h*(f(a,nu)+f(b,nu))
1       x=a-h
        t2=0.5*t1
        do 2 i=1,n
        x=x+2.*h
2       t2=t2+h*f(x,nu)
        s=0.33333333333d0*(4.*t2-t1)
        n=n+n
        if(abs(s-s0).le.(1.+abs(s))*eps) return
3       s0=s
        t1=t2
        h=h*0.5
        if(c+h.ne.c) goto 1
        n=-n
        return
        end


SUBROUTINE sub_hex_force

  USE PARACLUSTER
  USE CLUSTER
  USE POTENTIAL
  USE ENFORCE
  USE DISTANCE
  USE SUBSTRATE

  IMPLICIT NONE

  INTEGER :: n,i,j
  INTEGER :: mgo_type
  REAL(8) :: ener_mgo, aa
  REAL(8) :: funct1, funct2, funct1_dx, funct1_dy, funct2_dx, funct2_dy
  REAL(8), DIMENSION(3)   :: exp_term
  REAL(8) :: exp_term1, exp_term2, exp_term3
  REAL(8) :: s3 = sqrt(3.d0)

  REAL(8), DIMENSION(3)   :: a_, da_dx, da_dy, da_dz
  REAL(8), DIMENSION(3,3) :: b, db_dx, db_dy

 !-----------------------------------------------------
 ! Initialisation of local variables
 ener_mgo = 0.d0
 !------------------------------------------------------
 ! Initialisation of global variables
 ener_sub = 0.d0 ! This is global
 mgo_fx   = 0.d0
 mgo_fy   = 0.d0
 mgo_fz   = 0.d0

 ! Calculating coordination number
 CALL mgo_coord
 ! Now I have cn(i) and and its derivative w.r.t. x, y, z
 ! They are called
 ! mgo_cn(i)                                    adimensional
 ! mgo_dcn_dx(i), mgo_dcn_dy(i), mgo_dcn_dz(i)  [1/L]
 ! In this moment the unit is [1/Angstrom], and can be modified in mgo_coord_no

 ! Normalised positions  (in Angstrom and then *mgo_alat)
 mgo_x = (x + u) *arete(1) ! [A]
 mgo_y = (y + v) *arete(1) ! [A]
 mgo_z = (z + w) *arete(1) ! [A]

 aa = mgo_alat             ! [1/A]

 DO n = 1, natom
    mgo_type = itype(n)

    !-------------------------
    funct1 = (cos(aa*(mgo_x(n)+mgo_y(n)/s3)) + cos(aa*(mgo_x(n)-mgo_y(n)/s3)) + cos(2*aa*(mgo_y(n))/s3))
    funct2 = (cos(aa*(mgo_x(n)+mgo_y(n)*s3)) + cos(aa*(mgo_x(n)-mgo_y(n)*s3)) + cos(2*aa*(mgo_x(n))))
    funct1_dx = (-aa*(sin(aa*(mgo_x(n)+mgo_y(n)/s3))) - aa*(sin(aa*(mgo_x(n)-mgo_y(n)/s3))))
    funct2_dx=(-aa*sin(aa*(mgo_x(n)+mgo_y(n)*s3))-aa*sin(aa*(mgo_x(n)-mgo_y(n)*s3)) -2*aa*sin(2*aa*(mgo_x(n))))
    funct1_dy=(-aa/s3*(sin(aa*(mgo_x(n)+mgo_y(n)/s3)))+aa/s3*(sin(aa*(mgo_x(n)-mgo_y(n)/s3)))-aa*2/s3*sin((2*aa*(mgo_y(n))/s3)))
    funct2_dy = (-aa*s3*sin(aa*(mgo_x(n)+mgo_y(n)*s3)) + aa/s3*sin(aa*(mgo_x(n)-mgo_y(n)*s3)))
    !-------------------------
    DO j = 1,3
       b(:,j)    = ccc(mgo_type,:,j,1) +ccc(mgo_type,:,j,2)*funct1 &
                & +ccc(mgo_type,:,j,3)*funct2
       db_dx(:,j)=-ccc(mgo_type,:,j,2)*funct1_dx*aa+ccc(mgo_type,:,j,3)* funct2_dx
       db_dy(:,j)=-ccc(mgo_type,:,j,2)*funct1_dy*aa+ccc(mgo_type,:,j,3)* funct2_dy
    END DO
    !--------------------------
    exp_term = exp(-mgo_cn(n)/b(:,3))
    !--------------------------
    a_   = b(:,1) +b(:,2)*exp_term
    da_dx= db_dx(:,1) +  db_dx(:,2)*exp_term +  &
            & b(:,2)*exp_term *((-mgo_dcn_dx(n)*b(:,3) +mgo_cn(n)*db_dx(:,3))/b(:,3)**2)
    da_dy= db_dy(:,1) +  db_dy(:,2)*exp_term +  &
            & b(:,2)*exp_term *((-mgo_dcn_dy(n)*b(:,3) +mgo_cn(n)*db_dy(:,3))/b(:,3)**2)
    da_dz=    b(:,2)*exp_term *(-mgo_dcn_dz(n) /b(:,3))
    !--------------------------
    exp_term3= (mgo_z(n)-a_(3))
    exp_term1 = exp(-a_(2)*exp_term3)
     !exp_term2 = exp(-2.d0*a_(2)*exp_term3)
    exp_term2 = exp_term1*exp_term1
    !--------------------------
    ener_mgo = a_(1)     *(exp_term2-2.d0*exp_term1)
    mgo_fx(n)= da_dx(1) *(exp_term2-2.d0*exp_term1) &
                & +a_(1) *(exp_term2 *(-2.d0*da_dx(2)*exp_term3+2.d0*a_(2)*da_dx(3)) &
                &         -2.d0*exp_term1*(-da_dx(2)*exp_term3 +a_(2)*da_dx(3)) )
    mgo_fy(n)= da_dy(1) *(exp_term2-2.d0*exp_term1) &
                & +a_(1) *(exp_term2 *(-2.d0*da_dy(2)*exp_term3+2.d0*a_(2)*da_dy(3)) &
                &         -2.d0*exp_term1*(-da_dy(2)*exp_term3 +a_(2)*da_dy(3)) )
    mgo_fz(n)= da_dz(1) *(exp_term2-2.d0*exp_term1) &
                & +a_(1) *(exp_term2 *(-2.d0*da_dz(2)*exp_term3-2.d0*a_(2)*(1.d0-da_dz(3))) &
                &         -2.d0*exp_term1*(-da_dz(2)*exp_term3 -a_(2)*(1.d0-da_dz(3))) )

    ! Converting to arete(1) units
    mgo_fx(n) = -mgo_fx(n) *arete(1)
    mgo_fy(n) = -mgo_fy(n) *arete(1)
    mgo_fz(n) = -mgo_fz(n) *arete(1)

    ! Energy from the substrate
    ener_sub = ener_sub + ener_mgo

    !WRITE(900,*) ipas, n, mgo_fx(n), mgo_fy(n), mgo_fz(n)
    !WRITE(900,*) ipas, n, mgo_cn(n), mgo_dcn_dx(n), mgo_dcn_dy(n), mgo_dcn_dz(n)
 ENDDO
END SUBROUTINE sub_hex_force


SUBROUTINE EFT_PPZDD_MOD
! Two phytoplankton species model, one with higher muMax, lower KN and aI0,
! the other with lower  muMax, higher KN and aI0
use bio_MOD
implicit none
integer :: i,k
real :: dx,par_
real :: NO3, ZOO, DET, DET2
real :: PHYtot = 0d0
real :: PHYtot2= 0d0
real :: ppC_PN = 0d0
real :: pp_PN  = 0d0
real :: CHLtot = 0d0
real :: alphaG,Kp,gmax,RDN,RDN2,mz,PHYtot1,muNet

! The parameter that describes how feeding preference decreases with cell size
real :: tau
real :: RL(NPHY)  ! Feeding preference on each size class
real :: mu0(2) = [5.0, 1.0]
real ::  KN(2) = [0.1, 1.0]
real :: A0N(2) = [1D4, 0.001]
real :: aI0(2) = [0.05, 0.4]
real :: pp_ND2 = 0.

mu0(1)=params(imu0)
mu0(2)=mu0(1)*params(imu0B)
A0N(1)=params(iA0N)
A0N(2)=A0N(1)*10**(params(iA0N2))
aI0(1)=params(iaI0)
aI0(2)=aI0(1)*10**(params(iaI0B))
tau   =params(itau) * dtdays

Ez   = 0.6
Ep   = 0.5
Kp   = 0.5
gmax = params(igmax)
RDN  = 0.03
RDN2 = 0.01
mz   = params(imz)

!The feeding preference of the generic zooplankton for prey i
RL(1)=1d0
RL(2)=RL(1)*params(iRL2)

alphaG=1d0+10**params(ialphaG)

DO k = nlev,1,-1
   PHYtot  = 0d0  ! Calculate total PHY biomass
   PHYtot1 = 0d0  ! Total palatable prey
   PHYtot2 = 0d0  ! total P**alphaG
   pp_PN   = 0d0  ! total primary production (mmol N per d per m3)
   ppC_PN  = 0d0  ! total primary production (mmol C per d per m3)
   CHLtot  = 0d0  ! Total CHL A
   DET     = Vars(iDET,k)
   DET2    = Vars(iDET2,k)
   ZOO     = Vars(iZOO,k)  !Zooplankton biomass
   NO3     = Vars(iNO3,k)

   ! Check whether in the MLD or not
   if (k .lt. N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif
   Varout(oPAR_,k)=par_

!! Phytoplankton section:
   do i=1,NPHY
    ! Calculate phytoplankton growth rate, theta, and QN based on environmental conditions
     call EFT_phygrowth(mu0(i),KN(i),A0N(i), aI0(i), NO3,Temp(k),PAR(k),&
                     muNet, Varout(oQN(i),k),                           &
                     Varout(oTheta(i),k),                               &
                     Varout(oSI(i),k), Varout(oLno3(i),k))

    ! Calculate phytoplankton growth rate, theta, and QN based on environmental conditions
     call EFT_phygrowth(mu0(i),KN(i),A0N(i), aI0(i), NO3,Temp(k), par_, &
                     Varout(omuNet(i),k), Varout(oQN(i),k),             &
                     Varout(oTheta(i),k),                               &
                     Varout(oSI(i),k), Varout(oLno3(i),k))

     ! Total phytoplankton biomass
     PHYtot=PHYtot + Vars(iPHY(i),k)

     ! Total palatable prey biomass
     PHYtot1=PHYtot1 + Vars(iPHY(i),k)*RL(i)

     ! The denominator of the second term in Eq. 6 (for prey switching)
     PHYtot2=PHYtot2+Vars(iPHY(i),k)**alphaG*RL(i)

     pp_PN  =Vars(iPHY(i),k)*Varout(omuNet(i),k)+pp_PN

     ! Chl in this size class
     dx     =Vars(iPHY(i),k)/Varout(oQN(i),k)   *Varout(oTheta(i),k)
     ppC_PN =Vars(iPHY(i),k)*muNet/Varout(oQN(i),k)+ppC_PN
     CHLtot =CHLtot+dx
     Varout(oCHL(i),k)=dx
   enddo

   ! save total phytoplankton biomass
   Varout(oPHYt,k) = PHYtot
   Varout(oCHLt,k) = CHLtot
   Varout(oPON, k) = DET+DET2 + ZOO + PHYtot

   ! save phytoplankton average growth rate
   Varout(omuAvg,k)= pp_PN/PHYtot/dtdays

   ! save total NPP (carbon-based, unit: µg C L-1 d-1)
   Varout(oPPt,k)  = ppC_PN/dtdays*12d0
!---------------------------------------------------------------
!! ZOOplankton section:
   tf_z = TEMPBOL(Ez,Temp(k))

 ! The grazing dependence on total palatable prey (dimensionless; Eq. 7)
   gbar = grazing(grazing_formulation,kp,PHYtot1)

 !Zooplankton total ingestion rate
   INGES = tf_z*dtdays*gmax*gbar

 !Zooplankton excretion rate (-> DOM)
   RES  = INGES*(1d0-GGE-unass)

 !ZOOPLANKTON EGESTION (-> POM)
   EGES = INGES*unass

! Grazing rate on PHY each size class (specific to N-based Phy biomass, unit: d-1) (Eq. 12)

   ! Calculate the specific grazing rate for each size class
   do i = 1, NPHY
     ! Eq. 9 in Smith & Sergio
     Varout(oGraz(i),k)=(INGES*ZOO/PHYtot2)*Vars(iPHY(i),k)**(alphaG-1d0)*RL(i)
     Varout(oPHY(i),k) =Vars(iPHY(i),k)*(1d0+Varout(omuNet(i),k)-Varout(oGraz(i),k) - tau*(DET+PHYtot))
   enddo

!!End of zooplankton section
!=============================================================
!! Solve ODE functions:
  Zmort = ZOO*ZOO*dtdays* mz *tf_z  !Mortality term for ZOO

  ! For production/destruction matrix:
  pp_ND = dtdays* RDN *DET*tf_z
  pp_ND2= dtdays* RDN2*DET2*tf_z
  pp_NZ = ZOO*RES
  pp_DZ = ZOO*EGES+Zmort
  pp_ZP = ZOO*INGES

  Varout(oDET,k) = DET+pp_DZ-pp_ND-tau*(DET+PHYtot)*DET
  Varout(oDET2,k)= DET2+tau*(DET+PHYtot)**2-pp_ND2
  Varout(oNO3,k) = NO3+pp_ND+pp_NZ-pp_PN   +pp_ND2
  Varout(oZOO,k) = ZOO+pp_ZP-pp_NZ-pp_DZ
  Varout(oZ2N,k) = pp_NZ/dtdays
  Varout(oD2N,k) = pp_ND/dtdays

! Correct the unit for muNet:
  do i = 1, NPHY
     Varout(omuNet(i),k)=Varout(omuNet(i),k)/dtdays
     Varout(oGraz(i),k) =Varout(oGraz(i), k)/dtdays
  enddo
ENDDO
return
END SUBROUTINE


*> \brief  ZGESVDQ computes the singular value decomposition (SVD) with a QR-Preconditioned QR SVD Method for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESVDQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*      SUBROUTINE ZGESVDQ( JOBA, JOBP, JOBR, JOBU, JOBV, M, N, A, LDA,
*                          S, U, LDU, V, LDV, NUMRANK, IWORK, LIWORK,
*                          CWORK, LCWORK, RWORK, LRWORK, INFO )
*
*     .. Scalar Arguments ..
*      IMPLICIT    NONE
*      CHARACTER   JOBA, JOBP, JOBR, JOBU, JOBV
*      INTEGER     M, N, LDA, LDU, LDV, NUMRANK, LIWORK, LCWORK, LRWORK,
*                  INFO
*     ..
*     .. Array Arguments ..
*      COMPLEX*16       A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( * )
*      DOUBLE PRECISION S( * ), RWORK( * )
*      INTEGER          IWORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZCGESVDQ computes the singular value decomposition (SVD) of a complex
*> M-by-N matrix A, where M >= N. The SVD of A is written as
*>                                    [++]   [xx]   [x0]   [xx]
*>              A = U * SIGMA * V^*,  [++] = [xx] * [ox] * [xx]
*>                                    [++]   [xx]
*> where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal
*> matrix, and V is an N-by-N unitary matrix. The diagonal elements
*> of SIGMA are the singular values of A. The columns of U and V are the
*> left and the right singular vectors of A, respectively.
*> \endverbatim
*
*  Arguments
*  =========
*
*> \param[in] JOBA
*> \verbatim
*>  JOBA is CHARACTER*1
*>  Specifies the level of accuracy in the computed SVD
*>  = 'A' The requested accuracy corresponds to having the backward
*>        error bounded by || delta A ||_F <= f(m,n) * EPS * || A ||_F,
*>        where EPS = DLAMCH('Epsilon'). This authorises ZGESVDQ to
*>        truncate the computed triangular factor in a rank revealing
*>        QR factorization whenever the truncated part is below the
*>        threshold of the order of EPS * ||A||_F. This is aggressive
*>        truncation level.
*>  = 'M' Similarly as with 'A', but the truncation is more gentle: it
*>        is allowed only when there is a drop on the diagonal of the
*>        triangular factor in the QR factorization. This is medium
*>        truncation level.
*>  = 'H' High accuracy requested. No numerical rank determination based
*>        on the rank revealing QR factorization is attempted.
*>  = 'E' Same as 'H', and in addition the condition number of column
*>        scaled A is estimated and returned in  RWORK(1).
*>        N^(-1/4)*RWORK(1) <= ||pinv(A_scaled)||_2 <= N^(1/4)*RWORK(1)
*> \endverbatim
*>
*> \param[in] JOBP
*> \verbatim
*>  JOBP is CHARACTER*1
*>  = 'P' The rows of A are ordered in decreasing order with respect to
*>        ||A(i,:)||_\infty. This enhances numerical accuracy at the cost
*>        of extra data movement. Recommended for numerical robustness.
*>  = 'N' No row pivoting.
*> \endverbatim
*>
*> \param[in] JOBR
*> \verbatim
*>          JOBR is CHARACTER*1
*>          = 'T' After the initial pivoted QR factorization, ZGESVD is applied to
*>          the adjoint R**H of the computed triangular factor R. This involves
*>          some extra data movement (matrix transpositions). Useful for
*>          experiments, research and development.
*>          = 'N' The triangular factor R is given as input to CGESVD. This may be
*>          preferred as it involves less data movement.
*> \endverbatim
*>
*> \param[in] JOBU
*> \verbatim
*>          JOBU is CHARACTER*1
*>          = 'A' All M left singular vectors are computed and returned in the
*>          matrix U. See the description of U.
*>          = 'S' or 'U' N = min(M,N) left singular vectors are computed and returned
*>          in the matrix U. See the description of U.
*>          = 'R' Numerical rank NUMRANK is determined and only NUMRANK left singular
*>          vectors are computed and returned in the matrix U.
*>          = 'F' The N left singular vectors are returned in factored form as the
*>          product of the Q factor from the initial QR factorization and the
*>          N left singular vectors of (R**H , 0)**H. If row pivoting is used,
*>          then the necessary information on the row pivoting is stored in
*>          IWORK(N+1:N+M-1).
*>          = 'N' The left singular vectors are not computed.
*> \endverbatim
*>
*> \param[in] JOBV
*> \verbatim
*>          JOBV is CHARACTER*1
*>          = 'A', 'V' All N right singular vectors are computed and returned in
*>          the matrix V.
*>          = 'R' Numerical rank NUMRANK is determined and only NUMRANK right singular
*>          vectors are computed and returned in the matrix V. This option is
*>          allowed only if JOBU = 'R' or JOBU = 'N'; otherwise it is illegal.
*>          = 'N' The right singular vectors are not computed.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the input matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the input matrix A.  M >= N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array of dimensions LDA x N
*>          On entry, the input matrix A.
*>          On exit, if JOBU .NE. 'N' or JOBV .NE. 'N', the lower triangle of A contains
*>          the Householder vectors as stored by ZGEQP3. If JOBU = 'F', these Householder
*>          vectors together with CWORK(1:N) can be used to restore the Q factors from
*>          the initial pivoted QR factorization of A. See the description of U.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER.
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is DOUBLE PRECISION array of dimension N.
*>          The singular values of A, ordered so that S(i) >= S(i+1).
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*>          U is COMPLEX*16 array, dimension
*>          LDU x M if JOBU = 'A'; see the description of LDU. In this case,
*>          on exit, U contains the M left singular vectors.
*>          LDU x N if JOBU = 'S', 'U', 'R' ; see the description of LDU. In this
*>          case, U contains the leading N or the leading NUMRANK left singular vectors.
*>          LDU x N if JOBU = 'F' ; see the description of LDU. In this case U
*>          contains N x N unitary matrix that can be used to form the left
*>          singular vectors.
*>          If JOBU = 'N', U is not referenced.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER.
*>          The leading dimension of the array U.
*>          If JOBU = 'A', 'S', 'U', 'R',  LDU >= max(1,M).
*>          If JOBU = 'F',                 LDU >= max(1,N).
*>          Otherwise,                     LDU >= 1.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*>          V is COMPLEX*16 array, dimension
*>          LDV x N if JOBV = 'A', 'V', 'R' or if JOBA = 'E' .
*>          If JOBV = 'A', or 'V',  V contains the N-by-N unitary matrix  V**H;
*>          If JOBV = 'R', V contains the first NUMRANK rows of V**H (the right
*>          singular vectors, stored rowwise, of the NUMRANK largest singular values).
*>          If JOBV = 'N' and JOBA = 'E', V is used as a workspace.
*>          If JOBV = 'N', and JOBA.NE.'E', V is not referenced.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*>          LDV is INTEGER
*>          The leading dimension of the array V.
*>          If JOBV = 'A', 'V', 'R',  or JOBA = 'E', LDV >= max(1,N).
*>          Otherwise,                               LDV >= 1.
*> \endverbatim
*>
*> \param[out] NUMRANK
*> \verbatim
*>          NUMRANK is INTEGER
*>          NUMRANK is the numerical rank first determined after the rank
*>          revealing QR factorization, following the strategy specified by the
*>          value of JOBA. If JOBV = 'R' and JOBU = 'R', only NUMRANK
*>          leading singular values and vectors are then requested in the call
*>          of CGESVD. The final value of NUMRANK might be further reduced if
*>          some singular values are computed as zeros.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (max(1, LIWORK)).
*>          On exit, IWORK(1:N) contains column pivoting permutation of the
*>          rank revealing QR factorization.
*>          If JOBP = 'P', IWORK(N+1:N+M-1) contains the indices of the sequence
*>          of row swaps used in row pivoting. These can be used to restore the
*>          left singular vectors in the case JOBU = 'F'.
*>
*>          If LIWORK, LCWORK, or LRWORK = -1, then on exit, if INFO = 0,
*>          IWORK(1) returns the minimal LIWORK.
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*>          LIWORK is INTEGER
*>          The dimension of the array IWORK.
*>          LIWORK >= N + M - 1,  if JOBP = 'P';
*>          LIWORK >= N           if JOBP = 'N'.
*>
*>          If LIWORK = -1, then a workspace query is assumed; the routine
*>          only calculates and returns the optimal and minimal sizes
*>          for the CWORK, IWORK, and RWORK arrays, and no error
*>          message related to LCWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] CWORK
*> \verbatim
*>          CWORK is COMPLEX*12 array, dimension (max(2, LCWORK)), used as a workspace.
*>          On exit, if, on entry, LCWORK.NE.-1, CWORK(1:N) contains parameters
*>          needed to recover the Q factor from the QR factorization computed by
*>          ZGEQP3.
*>
*>          If LIWORK, LCWORK, or LRWORK = -1, then on exit, if INFO = 0,
*>          CWORK(1) returns the optimal LCWORK, and
*>          CWORK(2) returns the minimal LCWORK.
*> \endverbatim
*>
*> \param[in,out] LCWORK
*> \verbatim
*>          LCWORK is INTEGER
*>          The dimension of the array CWORK. It is determined as follows:
*>          Let  LWQP3 = N+1,  LWCON = 2*N, and let
*>          LWUNQ = { MAX( N, 1 ),  if JOBU = 'R', 'S', or 'U'
*>          { MAX( M, 1 ),  if JOBU = 'A'
*>          LWSVD = MAX( 3*N, 1 )
*>          LWLQF = MAX( N/2, 1 ), LWSVD2 = MAX( 3*(N/2), 1 ), LWUNLQ = MAX( N, 1 ),
*>          LWQRF = MAX( N/2, 1 ), LWUNQ2 = MAX( N, 1 )
*>          Then the minimal value of LCWORK is:
*>          = MAX( N + LWQP3, LWSVD )        if only the singular values are needed;
*>          = MAX( N + LWQP3, LWCON, LWSVD ) if only the singular values are needed,
*>                                   and a scaled condition estimate requested;
*>
*>          = N + MAX( LWQP3, LWSVD, LWUNQ ) if the singular values and the left
*>                                   singular vectors are requested;
*>          = N + MAX( LWQP3, LWCON, LWSVD, LWUNQ ) if the singular values and the left
*>                                   singular vectors are requested, and also
*>                                   a scaled condition estimate requested;
*>
*>          = N + MAX( LWQP3, LWSVD )        if the singular values and the right
*>                                   singular vectors are requested;
*>          = N + MAX( LWQP3, LWCON, LWSVD ) if the singular values and the right
*>                                   singular vectors are requested, and also
*>                                   a scaled condition etimate requested;
*>
*>          = N + MAX( LWQP3, LWSVD, LWUNQ ) if the full SVD is requested with JOBV = 'R';
*>                                   independent of JOBR;
*>          = N + MAX( LWQP3, LWCON, LWSVD, LWUNQ ) if the full SVD is requested,
*>                                   JOBV = 'R' and, also a scaled condition
*>                                   estimate requested; independent of JOBR;
*>          = MAX( N + MAX( LWQP3, LWSVD, LWUNQ ),
*>         N + MAX( LWQP3, N/2+LWLQF, N/2+LWSVD2, N/2+LWUNLQ, LWUNQ) ) if the
*>                         full SVD is requested with JOBV = 'A' or 'V', and
*>                         JOBR ='N'
*>          = MAX( N + MAX( LWQP3, LWCON, LWSVD, LWUNQ ),
*>         N + MAX( LWQP3, LWCON, N/2+LWLQF, N/2+LWSVD2, N/2+LWUNLQ, LWUNQ ) )
*>                         if the full SVD is requested with JOBV = 'A' or 'V', and
*>                         JOBR ='N', and also a scaled condition number estimate
*>                         requested.
*>          = MAX( N + MAX( LWQP3, LWSVD, LWUNQ ),
*>         N + MAX( LWQP3, N/2+LWQRF, N/2+LWSVD2, N/2+LWUNQ2, LWUNQ ) ) if the
*>                         full SVD is requested with JOBV = 'A', 'V', and JOBR ='T'
*>          = MAX( N + MAX( LWQP3, LWCON, LWSVD, LWUNQ ),
*>         N + MAX( LWQP3, LWCON, N/2+LWQRF, N/2+LWSVD2, N/2+LWUNQ2, LWUNQ ) )
*>                         if the full SVD is requested with JOBV = 'A', 'V' and
*>                         JOBR ='T', and also a scaled condition number estimate
*>                         requested.
*>          Finally, LCWORK must be at least two: LCWORK = MAX( 2, LCWORK ).
*>
*>          If LCWORK = -1, then a workspace query is assumed; the routine
*>          only calculates and returns the optimal and minimal sizes
*>          for the CWORK, IWORK, and RWORK arrays, and no error
*>          message related to LCWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (max(1, LRWORK)).
*>          On exit,
*>          1. If JOBA = 'E', RWORK(1) contains an estimate of the condition
*>          number of column scaled A. If A = C * D where D is diagonal and C
*>          has unit columns in the Euclidean norm, then, assuming full column rank,
*>          N^(-1/4) * RWORK(1) <= ||pinv(C)||_2 <= N^(1/4) * RWORK(1).
*>          Otherwise, RWORK(1) = -1.
*>          2. RWORK(2) contains the number of singular values computed as
*>          exact zeros in ZGESVD applied to the upper triangular or trapeziodal
*>          R (from the initial QR factorization). In case of early exit (no call to
*>          ZGESVD, such as in the case of zero matrix) RWORK(2) = -1.
*>
*>          If LIWORK, LCWORK, or LRWORK = -1, then on exit, if INFO = 0,
*>          RWORK(1) returns the minimal LRWORK.
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*>          LRWORK is INTEGER.
*>          The dimension of the array RWORK.
*>          If JOBP ='P', then LRWORK >= MAX(2, M, 5*N);
*>          Otherwise, LRWORK >= MAX(2, 5*N).
*>
*>          If LRWORK = -1, then a workspace query is assumed; the routine
*>          only calculates and returns the optimal and minimal sizes
*>          for the CWORK, IWORK, and RWORK arrays, and no error
*>          message related to LCWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  if ZBDSQR did not converge, INFO specifies how many superdiagonals
*>          of an intermediate bidiagonal form B (computed in ZGESVD) did not
*>          converge to zero.
*> \endverbatim
*
*> \par Further Details:
*  ========================
*>
*> \verbatim
*>
*>   1. The data movement (matrix transpose) is coded using simple nested
*>   DO-loops because BLAS and LAPACK do not provide corresponding subroutines.
*>   Those DO-loops are easily identified in this source code - by the CONTINUE
*>   statements labeled with 11**. In an optimized version of this code, the
*>   nested DO loops should be replaced with calls to an optimized subroutine.
*>   2. This code scales A by 1/SQRT(M) if the largest ABS(A(i,j)) could cause
*>   column norm overflow. This is the minial precaution and it is left to the
*>   SVD routine (CGESVD) to do its own preemptive scaling if potential over-
*>   or underflows are detected. To avoid repeated scanning of the array A,
*>   an optimal implementation would do all necessary scaling before calling
*>   CGESVD and the scaling in CGESVD can be switched off.
*>   3. Other comments related to code optimization are given in comments in the
*>   code, enlosed in [[double brackets]].
*> \endverbatim
*
*> \par Bugs, examples and comments
*  ===========================
*
*> \verbatim
*>  Please report all bugs and send interesting examples and/or comments to
*>  drmac@math.hr. Thank you.
*> \endverbatim
*
*> \par References
*  ===============
*
*> \verbatim
*>  [1] Zlatko Drmac, Algorithm 977: A QR-Preconditioned QR SVD Method for
*>      Computing the SVD with High Accuracy. ACM Trans. Math. Softw.
*>      44(1): 11:1-11:30 (2017)
*>
*>  SIGMA library, xGESVDQ section updated February 2016.
*>  Developed and coded by Zlatko Drmac, Department of Mathematics
*>  University of Zagreb, Croatia, drmac@math.hr
*> \endverbatim
*
*
*> \par Contributors:
*  ==================
*>
*> \verbatim
*> Developed and coded by Zlatko Drmac, Department of Mathematics
*>  University of Zagreb, Croatia, drmac@math.hr
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2018
*
*> \ingroup complex16GEsing
*
*  =====================================================================
      SUBROUTINE ZGESVDQ( JOBA, JOBP, JOBR, JOBU, JOBV, M, N, A, LDA,
     $                    S, U, LDU, V, LDV, NUMRANK, IWORK, LIWORK,
     $                    CWORK, LCWORK, RWORK, LRWORK, INFO )
*     .. Scalar Arguments ..
      IMPLICIT    NONE
      CHARACTER   JOBA, JOBP, JOBR, JOBU, JOBV
      INTEGER     M, N, LDA, LDU, LDV, NUMRANK, LIWORK, LCWORK, LRWORK,
     $            INFO
*     ..
*     .. Array Arguments ..
      COMPLEX*16       A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( * )
      DOUBLE PRECISION S( * ), RWORK( * )
      INTEGER          IWORK( * )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO,         ONE
      PARAMETER      ( ZERO = 0.0D0, ONE = 1.0D0 )
      COMPLEX*16       CZERO,                 CONE
      PARAMETER      ( CZERO = (0.0D0,0.0D0), CONE = (1.0D0,0.0D0) )
*     ..
*     .. Local Scalars ..
      INTEGER     IERR, NR, N1, OPTRATIO, p, q
      INTEGER     LWCON, LWQP3, LWRK_ZGELQF, LWRK_ZGESVD, LWRK_ZGESVD2,
     $            LWRK_ZGEQP3, LWRK_ZGEQRF, LWRK_ZUNMLQ, LWRK_ZUNMQR,
     $            LWRK_ZUNMQR2, LWLQF, LWQRF, LWSVD, LWSVD2, LWUNQ,
     $            LWUNQ2, LWUNLQ, MINWRK, MINWRK2, OPTWRK, OPTWRK2,
     $            IMINWRK, RMINWRK
      LOGICAL     ACCLA,  ACCLM, ACCLH, ASCALED, CONDA, DNTWU,  DNTWV,
     $            LQUERY, LSVC0, LSVEC, ROWPRM,  RSVEC, RTRANS, WNTUA,
     $            WNTUF,  WNTUR, WNTUS, WNTVA,   WNTVR
      DOUBLE PRECISION BIG, EPSLN, RTMP, SCONDA, SFMIN
      COMPLEX*16       CTMP
*     ..
*     .. Local Arrays
      COMPLEX*16         CDUMMY(1)
      DOUBLE PRECISION   RDUMMY(1)
*     ..
*     .. External Subroutines (BLAS, LAPACK)
      EXTERNAL    ZGELQF, ZGEQP3, ZGEQRF, ZGESVD, ZLACPY, ZLAPMT,
     $            ZLASCL, ZLASET, ZLASWP, ZDSCAL, DLASET, DLASCL,
     $            ZPOCON, ZUNMLQ, ZUNMQR, XERBLA
*     ..
*     .. External Functions (BLAS, LAPACK)
      LOGICAL     LSAME
      INTEGER                     IDAMAX
      DOUBLE PRECISION   ZLANGE,          DZNRM2, DLAMCH
      EXTERNAL    LSAME, ZLANGE,  IDAMAX, DZNRM2, DLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC   ABS, CONJG, MAX, MIN, DBLE, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      WNTUS  = LSAME( JOBU, 'S' ) .OR. LSAME( JOBU, 'U' )
      WNTUR  = LSAME( JOBU, 'R' )
      WNTUA  = LSAME( JOBU, 'A' )
      WNTUF  = LSAME( JOBU, 'F' )
      LSVC0  = WNTUS .OR. WNTUR .OR. WNTUA
      LSVEC  = LSVC0 .OR. WNTUF
      DNTWU  = LSAME( JOBU, 'N' )
*
      WNTVR  = LSAME( JOBV, 'R' )
      WNTVA  = LSAME( JOBV, 'A' ) .OR. LSAME( JOBV, 'V' )
      RSVEC  = WNTVR .OR. WNTVA
      DNTWV  = LSAME( JOBV, 'N' )
*
      ACCLA  = LSAME( JOBA, 'A' )
      ACCLM  = LSAME( JOBA, 'M' )
      CONDA  = LSAME( JOBA, 'E' )
      ACCLH  = LSAME( JOBA, 'H' ) .OR. CONDA
*
      ROWPRM = LSAME( JOBP, 'P' )
      RTRANS = LSAME( JOBR, 'T' )
*
      IF ( ROWPRM ) THEN
         IMINWRK = MAX( 1, N + M - 1 )
         RMINWRK = MAX( 2, M, 5*N )
      ELSE
         IMINWRK = MAX( 1, N )
         RMINWRK = MAX( 2, 5*N )
      END IF
      LQUERY = (LIWORK .EQ. -1 .OR. LCWORK .EQ. -1 .OR. LRWORK .EQ. -1)
      INFO  = 0
      IF ( .NOT. ( ACCLA .OR. ACCLM .OR. ACCLH ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( ROWPRM .OR. LSAME( JOBP, 'N' ) ) ) THEN
          INFO = -2
      ELSE IF ( .NOT.( RTRANS .OR. LSAME( JOBR, 'N' ) ) ) THEN
          INFO = -3
      ELSE IF ( .NOT.( LSVEC .OR. DNTWU ) ) THEN
         INFO = -4
      ELSE IF ( WNTUR .AND. WNTVA ) THEN
         INFO = -5
      ELSE IF ( .NOT.( RSVEC .OR. DNTWV )) THEN
         INFO = -5
      ELSE IF ( M.LT.0 ) THEN
         INFO = -6
      ELSE IF ( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
         INFO = -7
      ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF ( LDU.LT.1 .OR. ( LSVC0 .AND. LDU.LT.M ) .OR.
     $       ( WNTUF .AND. LDU.LT.N ) ) THEN
         INFO = -12
      ELSE IF ( LDV.LT.1 .OR. ( RSVEC .AND. LDV.LT.N ) .OR.
     $          ( CONDA .AND. LDV.LT.N ) ) THEN
         INFO = -14
      ELSE IF ( LIWORK .LT. IMINWRK .AND. .NOT. LQUERY ) THEN
         INFO = -17
      END IF
*
*
      IF ( INFO .EQ. 0 ) THEN
*        .. compute the minimal and the optimal workspace lengths
*        [[The expressions for computing the minimal and the optimal
*        values of LCWORK are written with a lot of redundancy and
*        can be simplified. However, this detailed form is easier for
*        maintenance and modifications of the code.]]
*
*        .. minimal workspace length for ZGEQP3 of an M x N matrix
         LWQP3 = N+1
*        .. minimal workspace length for ZUNMQR to build left singular vectors
         IF ( WNTUS .OR. WNTUR ) THEN
             LWUNQ  = MAX( N  , 1 )
         ELSE IF ( WNTUA ) THEN
             LWUNQ = MAX( M , 1 )
         END IF
*        .. minimal workspace length for ZPOCON of an N x N matrix
         LWCON = 2 * N
*        .. ZGESVD of an N x N matrix
         LWSVD = MAX( 3 * N, 1 )
         IF ( LQUERY ) THEN
             CALL ZGEQP3( M, N, A, LDA, IWORK, CDUMMY, CDUMMY, -1,
     $            RDUMMY, IERR )
             LWRK_ZGEQP3 = INT( CDUMMY(1) )
             IF ( WNTUS .OR. WNTUR ) THEN
                 CALL ZUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U,
     $                LDU, CDUMMY, -1, IERR )
                 LWRK_ZUNMQR = INT( CDUMMY(1) )
             ELSE IF ( WNTUA ) THEN
                 CALL ZUNMQR( 'L', 'N', M, M, N, A, LDA, CDUMMY, U,
     $                LDU, CDUMMY, -1, IERR )
                 LWRK_ZUNMQR = INT( CDUMMY(1) )
             ELSE
                 LWRK_ZUNMQR = 0
             END IF
         END IF
         MINWRK = 2
         OPTWRK = 2
         IF ( .NOT. (LSVEC .OR. RSVEC ) ) THEN
*            .. minimal and optimal sizes of the complex workspace if
*            only the singular values are requested
             IF ( CONDA ) THEN
                MINWRK = MAX( N+LWQP3, LWCON, LWSVD )
             ELSE
                MINWRK = MAX( N+LWQP3, LWSVD )
             END IF
             IF ( LQUERY ) THEN
                 CALL ZGESVD( 'N', 'N', N, N, A, LDA, S, U, LDU,
     $                V, LDV, CDUMMY, -1, RDUMMY, IERR )
                 LWRK_ZGESVD = INT( CDUMMY(1) )
                 IF ( CONDA ) THEN
                    OPTWRK = MAX( N+LWRK_ZGEQP3, N+LWCON, LWRK_ZGESVD )
                 ELSE
                    OPTWRK = MAX( N+LWRK_ZGEQP3, LWRK_ZGESVD )
                 END IF
             END IF
         ELSE IF ( LSVEC .AND. (.NOT.RSVEC) ) THEN
*            .. minimal and optimal sizes of the complex workspace if the
*            singular values and the left singular vectors are requested
             IF ( CONDA ) THEN
                 MINWRK = N + MAX( LWQP3, LWCON, LWSVD, LWUNQ )
             ELSE
                 MINWRK = N + MAX( LWQP3, LWSVD, LWUNQ )
             END IF
             IF ( LQUERY ) THEN
                IF ( RTRANS ) THEN
                   CALL ZGESVD( 'N', 'O', N, N, A, LDA, S, U, LDU,
     $                  V, LDV, CDUMMY, -1, RDUMMY, IERR )
                ELSE
                   CALL ZGESVD( 'O', 'N', N, N, A, LDA, S, U, LDU,
     $                  V, LDV, CDUMMY, -1, RDUMMY, IERR )
                END IF
                LWRK_ZGESVD = INT( CDUMMY(1) )
                IF ( CONDA ) THEN
                    OPTWRK = N + MAX( LWRK_ZGEQP3, LWCON, LWRK_ZGESVD,
     $                               LWRK_ZUNMQR )
                ELSE
                    OPTWRK = N + MAX( LWRK_ZGEQP3, LWRK_ZGESVD,
     $                               LWRK_ZUNMQR )
                END IF
             END IF
         ELSE IF ( RSVEC .AND. (.NOT.LSVEC) ) THEN
*            .. minimal and optimal sizes of the complex workspace if the
*            singular values and the right singular vectors are requested
             IF ( CONDA ) THEN
                 MINWRK = N + MAX( LWQP3, LWCON, LWSVD )
             ELSE
                 MINWRK = N + MAX( LWQP3, LWSVD )
             END IF
             IF ( LQUERY ) THEN
                 IF ( RTRANS ) THEN
                     CALL ZGESVD( 'O', 'N', N, N, A, LDA, S, U, LDU,
     $                    V, LDV, CDUMMY, -1, RDUMMY, IERR )
                 ELSE
                     CALL ZGESVD( 'N', 'O', N, N, A, LDA, S, U, LDU,
     $                    V, LDV, CDUMMY, -1, RDUMMY, IERR )
                 END IF
                 LWRK_ZGESVD = INT( CDUMMY(1) )
                 IF ( CONDA ) THEN
                     OPTWRK = N + MAX( LWRK_ZGEQP3, LWCON, LWRK_ZGESVD )
                 ELSE
                     OPTWRK = N + MAX( LWRK_ZGEQP3, LWRK_ZGESVD )
                 END IF
             END IF
         ELSE
*            .. minimal and optimal sizes of the complex workspace if the
*            full SVD is requested
             IF ( RTRANS ) THEN
                 MINWRK = MAX( LWQP3, LWSVD, LWUNQ )
                 IF ( CONDA ) MINWRK = MAX( MINWRK, LWCON )
                 MINWRK = MINWRK + N
                 IF ( WNTVA ) THEN
*                   .. minimal workspace length for N x N/2 ZGEQRF
                    LWQRF  = MAX( N/2, 1 )
*                   .. minimal workspace lengt for N/2 x N/2 ZGESVD
                    LWSVD2 = MAX( 3 * (N/2), 1 )
                    LWUNQ2 = MAX( N, 1 )
                    MINWRK2 = MAX( LWQP3, N/2+LWQRF, N/2+LWSVD2,
     $                        N/2+LWUNQ2, LWUNQ )
                    IF ( CONDA ) MINWRK2 = MAX( MINWRK2, LWCON )
                    MINWRK2 = N + MINWRK2
                    MINWRK = MAX( MINWRK, MINWRK2 )
                 END IF
             ELSE
                 MINWRK = MAX( LWQP3, LWSVD, LWUNQ )
                 IF ( CONDA ) MINWRK = MAX( MINWRK, LWCON )
                 MINWRK = MINWRK + N
                 IF ( WNTVA ) THEN
*                   .. minimal workspace length for N/2 x N ZGELQF
                    LWLQF  = MAX( N/2, 1 )
                    LWSVD2 = MAX( 3 * (N/2), 1 )
                    LWUNLQ = MAX( N , 1 )
                    MINWRK2 = MAX( LWQP3, N/2+LWLQF, N/2+LWSVD2,
     $                        N/2+LWUNLQ, LWUNQ )
                    IF ( CONDA ) MINWRK2 = MAX( MINWRK2, LWCON )
                    MINWRK2 = N + MINWRK2
                    MINWRK = MAX( MINWRK, MINWRK2 )
                 END IF
             END IF
             IF ( LQUERY ) THEN
                IF ( RTRANS ) THEN
                   CALL ZGESVD( 'O', 'A', N, N, A, LDA, S, U, LDU,
     $                  V, LDV, CDUMMY, -1, RDUMMY, IERR )
                   LWRK_ZGESVD = INT( CDUMMY(1) )
                   OPTWRK = MAX(LWRK_ZGEQP3,LWRK_ZGESVD,LWRK_ZUNMQR)
                   IF ( CONDA ) OPTWRK = MAX( OPTWRK, LWCON )
                   OPTWRK = N + OPTWRK
                   IF ( WNTVA ) THEN
                       CALL ZGEQRF(N,N/2,U,LDU,CDUMMY,CDUMMY,-1,IERR)
                       LWRK_ZGEQRF = INT( CDUMMY(1) )
                       CALL ZGESVD( 'S', 'O', N/2,N/2, V,LDV, S, U,LDU,
     $                      V, LDV, CDUMMY, -1, RDUMMY, IERR )
                       LWRK_ZGESVD2 = INT( CDUMMY(1) )
                       CALL ZUNMQR( 'R', 'C', N, N, N/2, U, LDU, CDUMMY,
     $                      V, LDV, CDUMMY, -1, IERR )
                       LWRK_ZUNMQR2 = INT( CDUMMY(1) )
                       OPTWRK2 = MAX( LWRK_ZGEQP3, N/2+LWRK_ZGEQRF,
     $                           N/2+LWRK_ZGESVD2, N/2+LWRK_ZUNMQR2 )
                       IF ( CONDA ) OPTWRK2 = MAX( OPTWRK2, LWCON )
                       OPTWRK2 = N + OPTWRK2
                       OPTWRK = MAX( OPTWRK, OPTWRK2 )
                   END IF
                ELSE
                   CALL ZGESVD( 'S', 'O', N, N, A, LDA, S, U, LDU,
     $                  V, LDV, CDUMMY, -1, RDUMMY, IERR )
                   LWRK_ZGESVD = INT( CDUMMY(1) )
                   OPTWRK = MAX(LWRK_ZGEQP3,LWRK_ZGESVD,LWRK_ZUNMQR)
                   IF ( CONDA ) OPTWRK = MAX( OPTWRK, LWCON )
                   OPTWRK = N + OPTWRK
                   IF ( WNTVA ) THEN
                      CALL ZGELQF(N/2,N,U,LDU,CDUMMY,CDUMMY,-1,IERR)
                      LWRK_ZGELQF = INT( CDUMMY(1) )
                      CALL ZGESVD( 'S','O', N/2,N/2, V, LDV, S, U, LDU,
     $                     V, LDV, CDUMMY, -1, RDUMMY, IERR )
                      LWRK_ZGESVD2 = INT( CDUMMY(1) )
                      CALL ZUNMLQ( 'R', 'N', N, N, N/2, U, LDU, CDUMMY,
     $                     V, LDV, CDUMMY,-1,IERR )
                      LWRK_ZUNMLQ = INT( CDUMMY(1) )
                      OPTWRK2 = MAX( LWRK_ZGEQP3, N/2+LWRK_ZGELQF,
     $                           N/2+LWRK_ZGESVD2, N/2+LWRK_ZUNMLQ )
                       IF ( CONDA ) OPTWRK2 = MAX( OPTWRK2, LWCON )
                       OPTWRK2 = N + OPTWRK2
                       OPTWRK = MAX( OPTWRK, OPTWRK2 )
                   END IF
                END IF
             END IF
         END IF
*
         MINWRK = MAX( 2, MINWRK )
         OPTWRK = MAX( 2, OPTWRK )
         IF ( LCWORK .LT. MINWRK .AND. (.NOT.LQUERY) ) INFO = -19
*
      END IF
*
      IF (INFO .EQ. 0 .AND. LRWORK .LT. RMINWRK .AND. .NOT. LQUERY) THEN
         INFO = -21
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGESVDQ', -INFO )
         RETURN
      ELSE IF ( LQUERY ) THEN
*
*     Return optimal workspace
*
          IWORK(1) = IMINWRK
          CWORK(1) = OPTWRK
          CWORK(2) = MINWRK
          RWORK(1) = RMINWRK
          RETURN
      END IF
*
*     Quick return if the matrix is void.
*
      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) THEN
*     .. all output is void.
         RETURN
      END IF
*
      BIG = DLAMCH('O')
      ASCALED = .FALSE.
      IF ( ROWPRM ) THEN
*           .. reordering the rows in decreasing sequence in the
*           ell-infinity norm - this enhances numerical robustness in
*           the case of differently scaled rows.
            DO 1904 p = 1, M
*               RWORK(p) = ABS( A(p,IZAMAX(N,A(p,1),LDA)) )
*               [[ZLANGE will return NaN if an entry of the p-th row is Nan]]
                RWORK(p) = ZLANGE( 'M', 1, N, A(p,1), LDA, RDUMMY )
*               .. check for NaN's and Inf's
                IF ( ( RWORK(p) .NE. RWORK(p) ) .OR.
     $               ( (RWORK(p)*ZERO) .NE. ZERO ) ) THEN
                    INFO = -8
                    CALL XERBLA( 'ZGESVDQ', -INFO )
                    RETURN
                END IF
 1904       CONTINUE
            DO 1952 p = 1, M - 1
            q = IDAMAX( M-p+1, RWORK(p), 1 ) + p - 1
            IWORK(N+p) = q
            IF ( p .NE. q ) THEN
               RTMP     = RWORK(p)
               RWORK(p) = RWORK(q)
               RWORK(q) = RTMP
            END IF
 1952       CONTINUE
*
            IF ( RWORK(1) .EQ. ZERO ) THEN
*              Quick return: A is the M x N zero matrix.
               NUMRANK = 0
               CALL DLASET( 'G', N, 1, ZERO, ZERO, S, N )
               IF ( WNTUS ) CALL ZLASET('G', M, N, CZERO, CONE, U, LDU)
               IF ( WNTUA ) CALL ZLASET('G', M, M, CZERO, CONE, U, LDU)
               IF ( WNTVA ) CALL ZLASET('G', N, N, CZERO, CONE, V, LDV)
               IF ( WNTUF ) THEN
                   CALL ZLASET( 'G', N, 1, CZERO, CZERO, CWORK, N )
                   CALL ZLASET( 'G', M, N, CZERO, CONE, U, LDU )
               END IF
               DO 5001 p = 1, N
                   IWORK(p) = p
 5001          CONTINUE
               IF ( ROWPRM ) THEN
                   DO 5002 p = N + 1, N + M - 1
                       IWORK(p) = p - N
 5002              CONTINUE
               END IF
               IF ( CONDA ) RWORK(1) = -1
               RWORK(2) = -1
               RETURN
            END IF
*
            IF ( RWORK(1) .GT. BIG / SQRT(DBLE(M)) ) THEN
*               .. to prevent overflow in the QR factorization, scale the
*               matrix by 1/sqrt(M) if too large entry detected
                CALL ZLASCL('G',0,0,SQRT(DBLE(M)),ONE, M,N, A,LDA, IERR)
                ASCALED = .TRUE.
            END IF
            CALL ZLASWP( N, A, LDA, 1, M-1, IWORK(N+1), 1 )
      END IF
*
*    .. At this stage, preemptive scaling is done only to avoid column
*    norms overflows during the QR factorization. The SVD procedure should
*    have its own scaling to save the singular values from overflows and
*    underflows. That depends on the SVD procedure.
*
      IF ( .NOT.ROWPRM ) THEN
          RTMP = ZLANGE( 'M', M, N, A, LDA, RWORK )
          IF ( ( RTMP .NE. RTMP ) .OR.
     $         ( (RTMP*ZERO) .NE. ZERO ) ) THEN
               INFO = -8
               CALL XERBLA( 'ZGESVDQ', -INFO )
               RETURN
          END IF
          IF ( RTMP .GT. BIG / SQRT(DBLE(M)) ) THEN
*             .. to prevent overflow in the QR factorization, scale the
*             matrix by 1/sqrt(M) if too large entry detected
              CALL ZLASCL('G',0,0, SQRT(DBLE(M)),ONE, M,N, A,LDA, IERR)
              ASCALED = .TRUE.
          END IF
      END IF
*
*     .. QR factorization with column pivoting
*
*     A * P = Q * [ R ]
*                 [ 0 ]
*
      DO 1963 p = 1, N
*        .. all columns are free columns
         IWORK(p) = 0
 1963 CONTINUE
      CALL ZGEQP3( M, N, A, LDA, IWORK, CWORK, CWORK(N+1), LCWORK-N,
     $     RWORK, IERR )
*
*    If the user requested accuracy level allows truncation in the
*    computed upper triangular factor, the matrix R is examined and,
*    if possible, replaced with its leading upper trapezoidal part.
*
      EPSLN = DLAMCH('E')
      SFMIN = DLAMCH('S')
*     SMALL = SFMIN / EPSLN
      NR = N
*
      IF ( ACCLA ) THEN
*
*        Standard absolute error bound suffices. All sigma_i with
*        sigma_i < N*EPS*||A||_F are flushed to zero. This is an
*        aggressive enforcement of lower numerical rank by introducing a
*        backward error of the order of N*EPS*||A||_F.
         NR = 1
         RTMP = SQRT(DBLE(N))*EPSLN
         DO 3001 p = 2, N
            IF ( ABS(A(p,p)) .LT. (RTMP*ABS(A(1,1))) ) GO TO 3002
               NR = NR + 1
 3001    CONTINUE
 3002    CONTINUE
*
      ELSEIF ( ACCLM ) THEN
*        .. similarly as above, only slightly more gentle (less aggressive).
*        Sudden drop on the diagonal of R is used as the criterion for being
*        close-to-rank-deficient. The threshold is set to EPSLN=DLAMCH('E').
*        [[This can be made more flexible by replacing this hard-coded value
*        with a user specified threshold.]] Also, the values that underflow
*        will be truncated.
         NR = 1
         DO 3401 p = 2, N
            IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR.
     $           ( ABS(A(p,p)) .LT. SFMIN ) ) GO TO 3402
            NR = NR + 1
 3401    CONTINUE
 3402    CONTINUE
*
      ELSE
*        .. RRQR not authorized to determine numerical rank except in the
*        obvious case of zero pivots.
*        .. inspect R for exact zeros on the diagonal;
*        R(i,i)=0 => R(i:N,i:N)=0.
         NR = 1
         DO 3501 p = 2, N
            IF ( ABS(A(p,p)) .EQ. ZERO ) GO TO 3502
            NR = NR + 1
 3501    CONTINUE
 3502    CONTINUE
*
         IF ( CONDA ) THEN
*           Estimate the scaled condition number of A. Use the fact that it is
*           the same as the scaled condition number of R.
*              .. V is used as workspace
               CALL ZLACPY( 'U', N, N, A, LDA, V, LDV )
*              Only the leading NR x NR submatrix of the triangular factor
*              is considered. Only if NR=N will this give a reliable error
*              bound. However, even for NR < N, this can be used on an
*              expert level and obtain useful information in the sense of
*              perturbation theory.
               DO 3053 p = 1, NR
                  RTMP = DZNRM2( p, V(1,p), 1 )
                  CALL ZDSCAL( p, ONE/RTMP, V(1,p), 1 )
 3053          CONTINUE
               IF ( .NOT. ( LSVEC .OR. RSVEC ) ) THEN
                   CALL ZPOCON( 'U', NR, V, LDV, ONE, RTMP,
     $                  CWORK, RWORK, IERR )
               ELSE
                   CALL ZPOCON( 'U', NR, V, LDV, ONE, RTMP,
     $                  CWORK(N+1), RWORK, IERR )
               END IF
               SCONDA = ONE / SQRT(RTMP)
*           For NR=N, SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1),
*           N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
*           See the reference [1] for more details.
         END IF
*
      ENDIF
*
      IF ( WNTUR ) THEN
          N1 = NR
      ELSE IF ( WNTUS .OR. WNTUF) THEN
          N1 = N
      ELSE IF ( WNTUA ) THEN
          N1 = M
      END IF
*
      IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN
*.......................................................................
*        .. only the singular values are requested
*.......................................................................
         IF ( RTRANS ) THEN
*
*         .. compute the singular values of R**H = [A](1:NR,1:N)**H
*           .. set the lower triangle of [A] to [A](1:NR,1:N)**H and
*           the upper triangle of [A] to zero.
            DO 1146 p = 1, MIN( N, NR )
               A(p,p) = CONJG(A(p,p))
               DO 1147 q = p + 1, N
                  A(q,p) = CONJG(A(p,q))
                  IF ( q .LE. NR ) A(p,q) = CZERO
 1147          CONTINUE
 1146       CONTINUE
*
            CALL ZGESVD( 'N', 'N', N, NR, A, LDA, S, U, LDU,
     $           V, LDV, CWORK, LCWORK, RWORK, INFO )
*
         ELSE
*
*           .. compute the singular values of R = [A](1:NR,1:N)
*
            IF ( NR .GT. 1 )
     $          CALL ZLASET( 'L', NR-1,NR-1, CZERO,CZERO, A(2,1), LDA )
            CALL ZGESVD( 'N', 'N', NR, N, A, LDA, S, U, LDU,
     $           V, LDV, CWORK, LCWORK, RWORK, INFO )
*
         END IF
*
      ELSE IF ( LSVEC .AND. ( .NOT. RSVEC) ) THEN
*.......................................................................
*       .. the singular values and the left singular vectors requested
*.......................................................................""""""""
         IF ( RTRANS ) THEN
*            .. apply ZGESVD to R**H
*            .. copy R**H into [U] and overwrite [U] with the right singular
*            vectors of R
            DO 1192 p = 1, NR
               DO 1193 q = p, N
                  U(q,p) = CONJG(A(p,q))
 1193          CONTINUE
 1192       CONTINUE
            IF ( NR .GT. 1 )
     $          CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, U(1,2), LDU )
*           .. the left singular vectors not computed, the NR right singular
*           vectors overwrite [U](1:NR,1:NR) as conjugate transposed. These
*           will be pre-multiplied by Q to build the left singular vectors of A.
               CALL ZGESVD( 'N', 'O', N, NR, U, LDU, S, U, LDU,
     $              U, LDU, CWORK(N+1), LCWORK-N, RWORK, INFO )
*
               DO 1119 p = 1, NR
                   U(p,p) = CONJG(U(p,p))
                   DO 1120 q = p + 1, NR
                      CTMP   = CONJG(U(q,p))
                      U(q,p) = CONJG(U(p,q))
                      U(p,q) = CTMP
 1120              CONTINUE
 1119          CONTINUE
*
         ELSE
*            .. apply ZGESVD to R
*            .. copy R into [U] and overwrite [U] with the left singular vectors
             CALL ZLACPY( 'U', NR, N, A, LDA, U, LDU )
             IF ( NR .GT. 1 )
     $         CALL ZLASET( 'L', NR-1, NR-1, CZERO, CZERO, U(2,1), LDU )
*            .. the right singular vectors not computed, the NR left singular
*            vectors overwrite [U](1:NR,1:NR)
                CALL ZGESVD( 'O', 'N', NR, N, U, LDU, S, U, LDU,
     $               V, LDV, CWORK(N+1), LCWORK-N, RWORK, INFO )
*               .. now [U](1:NR,1:NR) contains the NR left singular vectors of
*               R. These will be pre-multiplied by Q to build the left singular
*               vectors of A.
         END IF
*
*           .. assemble the left singular vector matrix U of dimensions
*              (M x NR) or (M x N) or (M x M).
         IF ( ( NR .LT. M ) .AND. ( .NOT.WNTUF ) ) THEN
             CALL ZLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU)
             IF ( NR .LT. N1 ) THEN
                CALL ZLASET( 'A',NR,N1-NR,CZERO,CZERO,U(1,NR+1), LDU )
                CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,
     $               U(NR+1,NR+1), LDU )
             END IF
         END IF
*
*           The Q matrix from the first QRF is built into the left singular
*           vectors matrix U.
*
         IF ( .NOT.WNTUF )
     $       CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U,
     $            LDU, CWORK(N+1), LCWORK-N, IERR )
         IF ( ROWPRM .AND. .NOT.WNTUF )
     $          CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(N+1), -1 )
*
      ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN
*.......................................................................
*       .. the singular values and the right singular vectors requested
*.......................................................................
          IF ( RTRANS ) THEN
*            .. apply ZGESVD to R**H
*            .. copy R**H into V and overwrite V with the left singular vectors
            DO 1165 p = 1, NR
               DO 1166 q = p, N
                  V(q,p) = CONJG(A(p,q))
 1166          CONTINUE
 1165       CONTINUE
            IF ( NR .GT. 1 )
     $          CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV )
*           .. the left singular vectors of R**H overwrite V, the right singular
*           vectors not computed
            IF ( WNTVR .OR. ( NR .EQ. N ) ) THEN
               CALL ZGESVD( 'O', 'N', N, NR, V, LDV, S, U, LDU,
     $              U, LDU, CWORK(N+1), LCWORK-N, RWORK, INFO )
*
               DO 1121 p = 1, NR
                   V(p,p) = CONJG(V(p,p))
                   DO 1122 q = p + 1, NR
                      CTMP   = CONJG(V(q,p))
                      V(q,p) = CONJG(V(p,q))
                      V(p,q) = CTMP
 1122              CONTINUE
 1121          CONTINUE
*
               IF ( NR .LT. N ) THEN
                   DO 1103 p = 1, NR
                      DO 1104 q = NR + 1, N
                          V(p,q) = CONJG(V(q,p))
 1104                 CONTINUE
 1103              CONTINUE
               END IF
               CALL ZLAPMT( .FALSE., NR, N, V, LDV, IWORK )
            ELSE
*               .. need all N right singular vectors and NR < N
*               [!] This is simple implementation that augments [V](1:N,1:NR)
*               by padding a zero block. In the case NR << N, a more efficient
*               way is to first use the QR factorization. For more details
*               how to implement this, see the " FULL SVD " branch.
                CALL ZLASET('G', N, N-NR, CZERO, CZERO, V(1,NR+1), LDV)
                CALL ZGESVD( 'O', 'N', N, N, V, LDV, S, U, LDU,
     $               U, LDU, CWORK(N+1), LCWORK-N, RWORK, INFO )
*
                DO 1123 p = 1, N
                   V(p,p) = CONJG(V(p,p))
                   DO 1124 q = p + 1, N
                      CTMP   = CONJG(V(q,p))
                      V(q,p) = CONJG(V(p,q))
                      V(p,q) = CTMP
 1124              CONTINUE
 1123           CONTINUE
                CALL ZLAPMT( .FALSE., N, N, V, LDV, IWORK )
            END IF
*
          ELSE
*            .. aply ZGESVD to R
*            .. copy R into V and overwrite V with the right singular vectors
             CALL ZLACPY( 'U', NR, N, A, LDA, V, LDV )
             IF ( NR .GT. 1 )
     $         CALL ZLASET( 'L', NR-1, NR-1, CZERO, CZERO, V(2,1), LDV )
*            .. the right singular vectors overwrite V, the NR left singular
*            vectors stored in U(1:NR,1:NR)
             IF ( WNTVR .OR. ( NR .EQ. N ) ) THEN
                CALL ZGESVD( 'N', 'O', NR, N, V, LDV, S, U, LDU,
     $               V, LDV, CWORK(N+1), LCWORK-N, RWORK, INFO )
                CALL ZLAPMT( .FALSE., NR, N, V, LDV, IWORK )
*               .. now [V](1:NR,1:N) contains V(1:N,1:NR)**H
             ELSE
*               .. need all N right singular vectors and NR < N
*               [!] This is simple implementation that augments [V](1:NR,1:N)
*               by padding a zero block. In the case NR << N, a more efficient
*               way is to first use the LQ factorization. For more details
*               how to implement this, see the " FULL SVD " branch.
                 CALL ZLASET('G', N-NR, N, CZERO,CZERO, V(NR+1,1), LDV)
                 CALL ZGESVD( 'N', 'O', N, N, V, LDV, S, U, LDU,
     $                V, LDV, CWORK(N+1), LCWORK-N, RWORK, INFO )
                 CALL ZLAPMT( .FALSE., N, N, V, LDV, IWORK )
             END IF
*            .. now [V] contains the adjoint of the matrix of the right singular
*            vectors of A.
          END IF
*
      ELSE
*.......................................................................
*       .. FULL SVD requested
*.......................................................................
         IF ( RTRANS ) THEN
*
*            .. apply ZGESVD to R**H [[this option is left for R&D&T]]
*
            IF ( WNTVR .OR. ( NR .EQ. N ) ) THEN
*            .. copy R**H into [V] and overwrite [V] with the left singular
*            vectors of R**H
            DO 1168 p = 1, NR
               DO 1169 q = p, N
                  V(q,p) = CONJG(A(p,q))
 1169          CONTINUE
 1168       CONTINUE
            IF ( NR .GT. 1 )
     $          CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV )
*
*           .. the left singular vectors of R**H overwrite [V], the NR right
*           singular vectors of R**H stored in [U](1:NR,1:NR) as conjugate
*           transposed
               CALL ZGESVD( 'O', 'A', N, NR, V, LDV, S, V, LDV,
     $              U, LDU, CWORK(N+1), LCWORK-N, RWORK, INFO )
*              .. assemble V
               DO 1115 p = 1, NR
                  V(p,p) = CONJG(V(p,p))
                  DO 1116 q = p + 1, NR
                     CTMP   = CONJG(V(q,p))
                     V(q,p) = CONJG(V(p,q))
                     V(p,q) = CTMP
 1116             CONTINUE
 1115          CONTINUE
               IF ( NR .LT. N ) THEN
                   DO 1101 p = 1, NR
                      DO 1102 q = NR+1, N
                         V(p,q) = CONJG(V(q,p))
 1102                 CONTINUE
 1101              CONTINUE
               END IF
               CALL ZLAPMT( .FALSE., NR, N, V, LDV, IWORK )
*
                DO 1117 p = 1, NR
                   U(p,p) = CONJG(U(p,p))
                   DO 1118 q = p + 1, NR
                      CTMP   = CONJG(U(q,p))
                      U(q,p) = CONJG(U(p,q))
                      U(p,q) = CTMP
 1118              CONTINUE
 1117           CONTINUE
*
                IF ( ( NR .LT. M ) .AND. .NOT.(WNTUF)) THEN
                  CALL ZLASET('A', M-NR,NR, CZERO,CZERO, U(NR+1,1), LDU)
                  IF ( NR .LT. N1 ) THEN
                     CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU)
                     CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,
     $                    U(NR+1,NR+1), LDU )
                  END IF
               END IF
*
            ELSE
*               .. need all N right singular vectors and NR < N
*            .. copy R**H into [V] and overwrite [V] with the left singular
*            vectors of R**H
*               [[The optimal ratio N/NR for using QRF instead of padding
*                 with zeros. Here hard coded to 2; it must be at least
*                 two due to work space constraints.]]
*               OPTRATIO = ILAENV(6, 'ZGESVD', 'S' // 'O', NR,N,0,0)
*               OPTRATIO = MAX( OPTRATIO, 2 )
                OPTRATIO = 2
                IF ( OPTRATIO*NR .GT. N ) THEN
                   DO 1198 p = 1, NR
                      DO 1199 q = p, N
                         V(q,p) = CONJG(A(p,q))
 1199                 CONTINUE
 1198              CONTINUE
                   IF ( NR .GT. 1 )
     $             CALL ZLASET('U',NR-1,NR-1, CZERO,CZERO, V(1,2),LDV)
*
                   CALL ZLASET('A',N,N-NR,CZERO,CZERO,V(1,NR+1),LDV)
                   CALL ZGESVD( 'O', 'A', N, N, V, LDV, S, V, LDV,
     $                  U, LDU, CWORK(N+1), LCWORK-N, RWORK, INFO )
*
                   DO 1113 p = 1, N
                      V(p,p) = CONJG(V(p,p))
                      DO 1114 q = p + 1, N
                         CTMP   = CONJG(V(q,p))
                         V(q,p) = CONJG(V(p,q))
                         V(p,q) = CTMP
 1114                 CONTINUE
 1113              CONTINUE
                   CALL ZLAPMT( .FALSE., N, N, V, LDV, IWORK )
*              .. assemble the left singular vector matrix U of dimensions
*              (M x N1), i.e. (M x N) or (M x M).
*
                   DO 1111 p = 1, N
                      U(p,p) = CONJG(U(p,p))
                      DO 1112 q = p + 1, N
                         CTMP   = CONJG(U(q,p))
                         U(q,p) = CONJG(U(p,q))
                         U(p,q) = CTMP
 1112                 CONTINUE
 1111              CONTINUE
*
                   IF ( ( N .LT. M ) .AND. .NOT.(WNTUF)) THEN
                      CALL ZLASET('A',M-N,N,CZERO,CZERO,U(N+1,1),LDU)
                      IF ( N .LT. N1 ) THEN
                        CALL ZLASET('A',N,N1-N,CZERO,CZERO,U(1,N+1),LDU)
                        CALL ZLASET('A',M-N,N1-N,CZERO,CONE,
     $                       U(N+1,N+1), LDU )
                      END IF
                   END IF
                ELSE
*                  .. copy R**H into [U] and overwrite [U] with the right
*                  singular vectors of R
                   DO 1196 p = 1, NR
                      DO 1197 q = p, N
                         U(q,NR+p) = CONJG(A(p,q))
 1197                 CONTINUE
 1196              CONTINUE
                   IF ( NR .GT. 1 )
     $             CALL ZLASET('U',NR-1,NR-1,CZERO,CZERO,U(1,NR+2),LDU)
                   CALL ZGEQRF( N, NR, U(1,NR+1), LDU, CWORK(N+1),
     $                  CWORK(N+NR+1), LCWORK-N-NR, IERR )
                   DO 1143 p = 1, NR
                       DO 1144 q = 1, N
                           V(q,p) = CONJG(U(p,NR+q))
 1144                  CONTINUE
 1143              CONTINUE
                  CALL ZLASET('U',NR-1,NR-1,CZERO,CZERO,V(1,2),LDV)
                  CALL ZGESVD( 'S', 'O', NR, NR, V, LDV, S, U, LDU,
     $                 V,LDV, CWORK(N+NR+1),LCWORK-N-NR,RWORK, INFO )
                  CALL ZLASET('A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV)
                  CALL ZLASET('A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV)
                  CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV)
                  CALL ZUNMQR('R','C', N, N, NR, U(1,NR+1), LDU,
     $                 CWORK(N+1),V,LDV,CWORK(N+NR+1),LCWORK-N-NR,IERR)
                  CALL ZLAPMT( .FALSE., N, N, V, LDV, IWORK )
*                 .. assemble the left singular vector matrix U of dimensions
*                 (M x NR) or (M x N) or (M x M).
                  IF ( ( NR .LT. M ) .AND. .NOT.(WNTUF)) THEN
                     CALL ZLASET('A',M-NR,NR,CZERO,CZERO,U(NR+1,1),LDU)
                     IF ( NR .LT. N1 ) THEN
                     CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU)
                     CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,
     $                    U(NR+1,NR+1),LDU)
                     END IF
                  END IF
                END IF
            END IF
*
         ELSE
*
*            .. apply ZGESVD to R [[this is the recommended option]]
*
             IF ( WNTVR .OR. ( NR .EQ. N ) ) THEN
*                .. copy R into [V] and overwrite V with the right singular vectors
                 CALL ZLACPY( 'U', NR, N, A, LDA, V, LDV )
                IF ( NR .GT. 1 )
     $          CALL ZLASET( 'L', NR-1,NR-1, CZERO,CZERO, V(2,1), LDV )
*               .. the right singular vectors of R overwrite [V], the NR left
*               singular vectors of R stored in [U](1:NR,1:NR)
                CALL ZGESVD( 'S', 'O', NR, N, V, LDV, S, U, LDU,
     $               V, LDV, CWORK(N+1), LCWORK-N, RWORK, INFO )
                CALL ZLAPMT( .FALSE., NR, N, V, LDV, IWORK )
*               .. now [V](1:NR,1:N) contains V(1:N,1:NR)**H
*               .. assemble the left singular vector matrix U of dimensions
*              (M x NR) or (M x N) or (M x M).
               IF ( ( NR .LT. M ) .AND. .NOT.(WNTUF)) THEN
                  CALL ZLASET('A', M-NR,NR, CZERO,CZERO, U(NR+1,1), LDU)
                  IF ( NR .LT. N1 ) THEN
                     CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU)
                     CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,
     $                    U(NR+1,NR+1), LDU )
                  END IF
               END IF
*
             ELSE
*              .. need all N right singular vectors and NR < N
*              .. the requested number of the left singular vectors
*               is then N1 (N or M)
*               [[The optimal ratio N/NR for using LQ instead of padding
*                 with zeros. Here hard coded to 2; it must be at least
*                 two due to work space constraints.]]
*               OPTRATIO = ILAENV(6, 'ZGESVD', 'S' // 'O', NR,N,0,0)
*               OPTRATIO = MAX( OPTRATIO, 2 )
               OPTRATIO = 2
               IF ( OPTRATIO * NR .GT. N ) THEN
                  CALL ZLACPY( 'U', NR, N, A, LDA, V, LDV )
                  IF ( NR .GT. 1 )
     $            CALL ZLASET('L', NR-1,NR-1, CZERO,CZERO, V(2,1),LDV)
*              .. the right singular vectors of R overwrite [V], the NR left
*                 singular vectors of R stored in [U](1:NR,1:NR)
                  CALL ZLASET('A', N-NR,N, CZERO,CZERO, V(NR+1,1),LDV)
                  CALL ZGESVD( 'S', 'O', N, N, V, LDV, S, U, LDU,
     $                 V, LDV, CWORK(N+1), LCWORK-N, RWORK, INFO )
                  CALL ZLAPMT( .FALSE., N, N, V, LDV, IWORK )
*                 .. now [V] contains the adjoint of the matrix of the right
*                 singular vectors of A. The leading N left singular vectors
*                 are in [U](1:N,1:N)
*                 .. assemble the left singular vector matrix U of dimensions
*                 (M x N1), i.e. (M x N) or (M x M).
                  IF ( ( N .LT. M ) .AND. .NOT.(WNTUF)) THEN
                      CALL ZLASET('A',M-N,N,CZERO,CZERO,U(N+1,1),LDU)
                      IF ( N .LT. N1 ) THEN
                        CALL ZLASET('A',N,N1-N,CZERO,CZERO,U(1,N+1),LDU)
                        CALL ZLASET( 'A',M-N,N1-N,CZERO,CONE,
     $                       U(N+1,N+1), LDU )
                      END IF
                  END IF
               ELSE
                  CALL ZLACPY( 'U', NR, N, A, LDA, U(NR+1,1), LDU )
                  IF ( NR .GT. 1 )
     $            CALL ZLASET('L',NR-1,NR-1,CZERO,CZERO,U(NR+2,1),LDU)
                  CALL ZGELQF( NR, N, U(NR+1,1), LDU, CWORK(N+1),
     $                 CWORK(N+NR+1), LCWORK-N-NR, IERR )
                  CALL ZLACPY('L',NR,NR,U(NR+1,1),LDU,V,LDV)
                  IF ( NR .GT. 1 )
     $            CALL ZLASET('U',NR-1,NR-1,CZERO,CZERO,V(1,2),LDV)
                  CALL ZGESVD( 'S', 'O', NR, NR, V, LDV, S, U, LDU,
     $                 V, LDV, CWORK(N+NR+1), LCWORK-N-NR, RWORK, INFO )
                  CALL ZLASET('A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV)
                  CALL ZLASET('A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV)
                  CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV)
                  CALL ZUNMLQ('R','N',N,N,NR,U(NR+1,1),LDU,CWORK(N+1),
     $                 V, LDV, CWORK(N+NR+1),LCWORK-N-NR,IERR)
                  CALL ZLAPMT( .FALSE., N, N, V, LDV, IWORK )
*               .. assemble the left singular vector matrix U of dimensions
*              (M x NR) or (M x N) or (M x M).
                  IF ( ( NR .LT. M ) .AND. .NOT.(WNTUF)) THEN
                     CALL ZLASET('A',M-NR,NR,CZERO,CZERO,U(NR+1,1),LDU)
                     IF ( NR .LT. N1 ) THEN
                     CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU)
                     CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,
     $                    U(NR+1,NR+1), LDU )
                     END IF
                  END IF
               END IF
             END IF
*        .. end of the "R**H or R" branch
         END IF
*
*           The Q matrix from the first QRF is built into the left singular
*           vectors matrix U.
*
         IF ( .NOT. WNTUF )
     $       CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U,
     $            LDU, CWORK(N+1), LCWORK-N, IERR )
         IF ( ROWPRM .AND. .NOT.WNTUF )
     $          CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(N+1), -1 )
*
*     ... end of the "full SVD" branch
      END IF
*
*     Check whether some singular values are returned as zeros, e.g.
*     due to underflow, and update the numerical rank.
      p = NR
      DO 4001 q = p, 1, -1
          IF ( S(q) .GT. ZERO ) GO TO 4002
          NR = NR - 1
 4001 CONTINUE
 4002 CONTINUE
*
*     .. if numerical rank deficiency is detected, the truncated
*     singular values are set to zero.
      IF ( NR .LT. N ) CALL DLASET( 'G', N-NR,1, ZERO,ZERO, S(NR+1), N )
*     .. undo scaling; this may cause overflow in the largest singular
*     values.
      IF ( ASCALED )
     $   CALL DLASCL( 'G',0,0, ONE,SQRT(DBLE(M)), NR,1, S, N, IERR )
      IF ( CONDA ) RWORK(1) = SCONDA
      RWORK(2) = p - NR
*     .. p-NR is the number of singular values that are computed as
*     exact zeros in ZGESVD() applied to the (possibly truncated)
*     full row rank triangular (trapezoidal) factor of A.
      NUMRANK = NR
*
      RETURN
*
*     End of ZGESVDQ
*
      END


      subroutine nuts(u1,u2,uu)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function calculates the plant stress factor caused by limited
!!    supply of nitrogen or phosphorus

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    u1          |kg/ha         |actual amount of element in plant
!!    u2          |kg/ha         |optimal amount of element in plant
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    uu          |none          |fraction of optimal plant growth achieved
!!                               |where reduction is caused by plant element
!!                               |deficiency
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real, intent (in) :: u1, u2
      real, intent (out) :: uu

      uu = 0.

      uu = 200. * (u1 / (u2 + .0001) - .5)

      if (uu <= 0.) then
        uu = 0.
      else
        if (uu < 99.) then
          uu = uu / (uu + Exp(3.535 - .02597 * uu))
        else
          uu = 1.
        endif
      end if

      if (u2 <= 1.e-6) uu = 1.

      return
      end


c=======================================================================
c
c     subroutine COVFILRERING
c
c     This function implements a cov. matrix correction for a filtering
c     level between 0% and 100%.
c
c-----------------------------------------------------------------------
      SUBROUTINE covfiltering ( p, cov, filter, iwork, dwork,
     &                          covopt, epsilon, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       p       : matrix size (p>0)                              integer
c       cov     : covariance matrix (p*p)                         double
c       filter  : filtering level (0<=filter<=1)                  double
c
c     WORKSPACE
c       iwork   : 12*p + 3                                       integer
c       dwork   : (p*(15*p + 61))/2 + 1                           double
c
c     OUTPUT
c       covopt  : optimal cov. matrix (p*p)                       double
c       epsilon : calibration parameter                           double
c       info    : diagnostic argument                            integer
c
c     CALL
c       SDLS    : Semidefinite Least Square optimization
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER p, info
      DOUBLE PRECISION filter, epsilon, cov(*), covopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, nbCst, pisdls, pdsdls, pdb, pdC, pdS
      DOUBLE PRECISION traceCov, epsMean, epsMedian, epsi, epsj, vpi,
     &                 vpj, vEmp, vMean, vMedian, vmin, v, coef, a, b,
     &                 cstPrecision, sum, EPS,
     &                 minEPS
      PARAMETER ( EPS = 1.E-15, minEPS = 1.E-8, cstPrecision  = 1.E-15 )
c
c     external subroutines
      EXTERNAL YV, TM, sdls, eigenvd, calepsmedian
c
c     intrinsic functions
      INTRINSIC MAX, ABS
c
c-----------------------------------------------------------------------
c
c     initializations
      info  = 0     ! diagnostic argument
      nbCst = 0     ! number of SDLS constraints
      epsilon = 0.0 ! correction parameter
      CALL YM ( p, p, cov, covopt ) ! copy cov -> covopt
c
c     pointers for integer work space : iworka
c     ---------------------------------------
      pisdls = 1
c     pisdls : pointer for SDLS (12*p + 3)
c
c     Total size of iwork array = 12*p + 3
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdS    = 1
c     pdS    : pointer for eigenvalues (p)
      pdC    = pdS + ( p )
c     pdC    : pointer for cst. matrix SDLS (p*p)
      pdb    = pdC + ( p*p )
c     pdb    : pointer for cst. vector SDLS (1)
      pdsdls = pdb + ( 1 )
c     pdsdls : pointer for SDLS
c                    5*p*(p+1)/2 + p*(4*p + 27)
c
c     Total size of dwork array = p + p*p + 1 + 5*p*(p+1)/2  + p*(4*p + 27)
c                               = (p*(15*p + 61))/2 + 1
c
c-----------------------------------------------------------------------
c
c     if filter=0 no correction
      IF (filter .LE. EPS) RETURN
c
c     cov. matrix trace
      CALL TM ( p, cov, traceCov )
      IF (traceCov .LT. EPS) RETURN
c
c     Singular value decomposition
c     cov = U*Diag(S)*U', with sorted singular values S(i) >= S(i+1)
      CALL eigenvd ( p, cov, dwork(pdsdls), dwork(pdS),
     &               dwork(pdsdls + p*p + 10*p), info )
c
c     &              dwork(pdsdls + p*p + 6*p), info)
c
c     eps mean and % exlpain variance
      epsMean = traceCov / p
c      CALL calepsmean(p, cov, epsMean, info)
      sum = 0.0
      DO i = 1,p
        epsi = dwork(pdS + i - 1)
        IF (epsi .GT. epsMean) THEN
            sum = sum + epsi
        ENDIF
      ENDDO
      vMean = sum / traceCov
c
c     eps median and % explain variance
      CALL calepsmedian ( p, cov, dwork(pdsdls), epsMedian, info )
      sum = 0.0
      DO i = 1,p
        epsi = dwork(pdS + i - 1)
        IF (epsi .GT. epsMedian) THEN
            sum = sum + epsi
        ENDIF
      ENDDO
      vMedian = sum / traceCov
c
c     empiric % explain variance between [2, 20]
c      IF ( p .LE. 20) THEN
        a = -0.09999/18.0
        b = 0.9999 - 2.0*a
        vEmp = a*p + b  !
c      ELSE
c        vEmp = 0.9
c      ENDIF
c
c     % minimum of explain variance
c     vmin = Max(vEmp, vMean, vMedian)
      vmin = MAX(vMean, vMedian)
      vmin = MAX(vEmp, vmin)
c
c     % explain variance: filter [0, 1] -> v [1 vmin]
      v = (vmin - 1.0)*filter + 1.0
c
c     minimum eigenvalue (linear interpolation)
      epsi = dwork(pdS)
      epsj = epsi
      vpi  = epsi/traceCov
      vpj  = vpi
      IF (p .GT. 1) THEN
        DO i = 2,p
            epsj = dwork(pdS + i - 1)
            vpj = vpj + epsj/traceCov
            IF (vpj .LT. v) THEN
                epsi = epsj
                vpi  = vpj
            ELSE
                GOTO 1
            ENDIF
        ENDDO
      ENDIF
    1 CONTINUE
      IF (ABS(vpi - vpj) .LT. EPS) THEN
        coef = 0.0
      ELSE
        coef = (v - vpj)/(vpi - vpj)
      ENDIF
      epsilon = epsj + coef*(epsi - epsj)
      epsilon = MAX(epsilon, minEPS)
c
c     optimization with SDLS
      CALL sdls ( p, cov, nbCst, dwork(pdC), dwork(pdb),
     &            cstPrecision, epsilon,
     &            iwork(pisdls), dwork(pdsdls),
     &            covopt, info )
      IF (info .LT. 0) RETURN
c
      RETURN
      END


      subroutine runCY_0000li1i2(k,l,i1,i2,Xtwiddle,Gtwiddle,Shat7zz,N0)
      implicit none
C---  Expression for Eq. 5.60c
C---  Calculates C0000li1i2, requires C0000lli1
C---  Small terms of order Xtwiddle(0,k)*C00iiii,Xtwiddle(0,0)*C00iiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,i2,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7zz(np,z4max,-2:0)

      if (  (i1 .eq. l) .or. (i2 .eq. l)
     . .or. (i1 .eq. 0) .or. (i2 .eq. 0)) then
      return
      endif

      do ep=-2,0
      Cv(czzzziii(z3(l,i1,i2))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Cv(czzzziii(z3(l,l,i2))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Cv(czzzziii(z3(l,l,i1))+N0,ep)
     . +Gtwiddle(k,1)*Shat7zz(1,z4(l,l,i1,i2),ep)
     . +Gtwiddle(k,2)*Shat7zz(2,z4(l,l,i1,i2),ep)
     . +Xtwiddle(0,k)*Cv(czziiii(z4(l,l,i1,i2))+N0,ep)
     . -Xtwiddle(0,0)*Cv(czziiiii(z5(k,l,l,i1,i2))+N0,ep))
     . /(4d0*Gtwiddle(k,l))

      enddo

      return
      end


MODULE rotation
!
!   Module for rotations of coordinates including
!   1) cylindrical to tilted (magnetic plane) cylindrical
!   2) tilted cylindrical to cartesian
!   3) cartesian to cylindrical
!
!
! !  DOUBLE PRECISION ::

!  r = sqrt(x*x+y*y)
!       rinv = 1.0/r
!       Er = Ertilt
!       Ez = Eztilt*sintheta
!       Ex = Er*x*rinv + Ez*y*rinv
!       Ey = Er*y*rinv - Ez*x*rinv
!
END MODULE rotation


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

      SUBROUTINE EXTND1 (MXND, XN, YN, ANGLE, N1, N2, N3, X, Y, DIST)
C***********************************************************************

C  SUBROUTINE EXCORN = CALCULATES A POSITION AN AVERAGE LENGTH AWAY
C                      FROM A CORNER NODE

C***********************************************************************

      DIMENSION XN (MXND), YN (MXND), ANGLE (MXND)
      DIMENSION X(1), Y(1)

      CANG = (ANGLE (N2) * .5)
      ANG = ATAN2 (YN (N1) - YN (N2), XN (N1) - XN (N2)) - CANG
      DIST1 = SQRT ((YN (N2) - YN (N1)) **2 +  (XN (N2) - XN (N1)) **2)
      DIST2 = SQRT ((YN (N3) - YN (N2)) **2 +  (XN (N3) - XN (N2)) **2)
      DIST = (DIST1 + DIST2) * .5
      IF (CANG .EQ. 0.) THEN
         ADIST = DIST
      ELSE
         ADIST = DIST / SIN (CANG)
      ENDIF

      X(1) = ADIST * COS (ANG) + XN (N2)
      Y(1) = ADIST * SIN (ANG) + YN (N2)

      RETURN

      END


#version 120

varying vec2 p;

uniform bool transparent;

uniform float time;
uniform int x_period = 8;
#pragma machuchu slider x_period 1 30
uniform int y_period = 8;
#pragma machuchu slider y_period 1 30

const float TRESHOLD = 0.99;
const float PI = 3.1415926535897932384626433832795;
const float TAU = 6.283185307179586;

float f(float x, float period)
{
    float val = abs(sin(TAU*(x+1.0)*0.5*period));
    return val >= TRESHOLD ? 1.0 : 0.0;
}

void main()
{
    float val = f(p.x, float(x_period))
              + f(p.y, float(y_period));
    if (transparent)
        val *= 0.5;
    gl_FragColor = vec4(1.0-val, 1.0-val, 1.0, 1.0);
}


      SUBROUTINE SSLOT1(IOPT)
C                  IOPT-  CSLOT3 = 0,  CSLOT4 = 1
C     THE ECPT DATA FOR THESE ELEMENTS ARE
C
C     FIELD   CSLOT3                CSLOT4
C       1       ID                  ID
C       2       SIL1                SIL1
C       3       SIL2                SIL2
C       4       SIL3                SIL3
C       5       RHO                 SIL4
C       6       BULK                RHO
C       7       M                   BULK
C       8       N                   M
C       9       CID1                N
C       10      R1                  CID1
C      11       Z1                  R1
C      12       W1                  Z1
C      13       CID2                W1
C      14       R2                  CID2
C      15       Z2                  R2
C      16       W2                  Z2
C      17       CID3                W2
C      18       R3                  CID3
C      19       Z3                  R3
C      20       W3                  Z3
C      21       TEMP                W3
C      22                           CID4
C      23                           R4
C      24                           Z4
C***** 25                           W4
C***** 26                           TEMP
      INTEGER NECPT(100),NOUT(100)
      DIMENSION SV(24)
      COMMON/SDR2X5/ ECPT(100),OUT(100)
      COMMON/SDR2X6/ R(4),Z(4),RHO,FACT,A,NC1,NC2,NC3,IRET,NR,
     1 COL,NR1,NR2,NR3,II,IJ
      EQUIVALENCE (ECPT(1),NECPT(1)),(OUT(1),NOUT(1)),(OUT(6),SV(1))
      IOT = 6
      DO 10 I=1,30
   10 NOUT(I) = 0
      NC1 =1
      NC2 =2
      NC3 =3
      IF(IOPT.NE.0) GO TO 30
C     SET UP FOR THE SLOT3 ELEMENT
C****
      RHO = ECPT(5)
      IRET=4
      DO 20 I=1,3
      NR= 4*(I-1)+10
      R(I)=ECPT(NR)
      Z(I)=ECPT(NR+1)
   20 CONTINUE
      GO TO 80
C****
C     THE CSLOT4 ELEMENT IS CALCULATED AS FOLLOWS
   30 CONTINUE
      RHO = ECPT(6)*4.0
      DO 40 I =1,4
      NR = 4*(I-1) +11
      R(I) = ECPT(NR)
      Z(I) = ECPT(NR+1)
   40 CONTINUE
      NCOL=6
      IRET =1
      GO TO 80
   50 NC3 =4
      IRET=2
      GO TO 80
   60 NC2 =3
      IRET=3
      GO TO 80
   70 NC1= 2
      IRET=4
   80 A =    (R(NC1)*(Z(NC2)-Z(NC3)) +R(NC2)*(Z(NC3)-Z(NC1))
     1        + R(NC3)*(Z(NC1)-Z(NC2)) )
      FACT = - RHO *A
      SV(NC1)=(Z(NC2) -Z(NC3))/FACT+SV(NC1)
      SV(NC2)=(Z(NC3) -Z(NC1))/FACT+SV(NC2)
      SV(NC3)=(Z(NC1) -Z(NC2))/FACT+SV(NC3)
C
      NR1= 3+IOPT +NC1
      NR2= 3+IOPT +NC2
      NR3= 3+IOPT +NC3
C
      SV(NR1)=(R(NC3)-R(NC2))/FACT +SV(NR1)
      SV(NR2)=(R(NC1)-R(NC3))/FACT +SV(NR2)
      SV(NR3)=(R(NC2)-R(NC1))/FACT +SV(NR3)
C
      GO TO (50,60,70,90),IRET
C
   90 CONTINUE
      NR = IOPT+3
      IF(IOPT .EQ. 1) RHO =RHO/4.0
      DO 100 I =1,NR
      J=I+1
      IF(J .GT. IOPT+3) J =J-IOPT-3
      FACT = 1.0/(SQRT((R(J)-R(I))**2+(Z(J)-Z(I))**2)*RHO)
      II=  IOPT*(I+1) +4*I+3
      FACT = 1.0/(SQRT((R(J)-R(I))**2+(Z(J)-Z(I))**2)*RHO)
      II=  IOPT*(I+1) +4*I+3
      IJ = II +J -I
      SV(II) = FACT
      SV(IJ) =-FACT
  100 CONTINUE
C
C*****
C     WRAP UP OUTPUT
C*****
      NOUT(1)= NECPT(1)
      NOUT(2)= NECPT(2)
      NOUT(3)= NECPT(3)
      NOUT(4)= NECPT(4)
      IF(IOPT.GT.0) NOUT(5)= NECPT(5)
      RETURN
      END


module unit_normals

  use common, only : wp

contains

  subroutine local_orth_vectors_q(i, G, B)

    use mpi3dbasic, only : rank
    use datatypes, only: block_grid_t, block_boundary

    type(block_boundary),intent(inout) :: B
    type(block_grid_t),intent(in) :: G
    integer, intent(in) :: i
    integer :: my, mz, py, pz
    real(kind = wp), dimension(1:3) :: l, m, n  !< three local othogonal vectors
    integer :: y, z
    real(kind = wp) :: norm, q_x, q_y, q_z

    my = G%C%mr
    mz = G%C%ms
    py = G%C%pr
    pz = G%C%ps

    l(:) = 0.0_wp
    m(:) = 0.0_wp

    do z = mz, pz
       do y = my, py

          q_x = G%metricx(i, y, z, 1)
          q_y = G%metricy(i, y, z, 1)
          q_z = G%metricz(i, y, z, 1)

          norm = sqrt(q_x**2.0_wp + q_y**2.0_wp + q_z**2.0_wp)

          ! outward unit vectors
          n(1) = q_x/norm
          n(2) = q_y/norm
          n(3) = q_z/norm

          ! compute two other orthogonal vectors, l, m
          call gen_orth_vectors(l, m, n)

          B%n_n(y, z, 1) = n(1)
          B%n_n(y, z, 2) = n(2)
          B%n_n(y, z, 3) = n(3)

          B%n_m(y, z, 1) = m(1)
          B%n_m(y, z, 2) = m(2)
          B%n_m(y, z, 3) = m(3)

          B%n_l(y, z, 1) = l(1)
          B%n_l(y, z, 2) = l(2)
          B%n_l(y, z, 3) = l(3)

       end do
    end do
  end subroutine  Local_orth_vectors_q

  subroutine local_orth_vectors_r(i, G, B)

    use mpi3dbasic, only : rank
    use datatypes, only: block_grid_t, block_boundary

    type(block_boundary),intent(inout) :: B
    type(block_grid_t),intent(in) :: G
    integer, intent(in) :: i
    integer :: mx, mz, px, pz
    real(kind = wp), dimension(1:3) :: l, m, n  !< three local othogonal vectors
    integer :: x, z
    real(kind = wp) :: norm, r_x, r_y, r_z

    mx = G%C%mq
    mz = G%C%ms
    px = G%C%pq
    pz = G%C%ps

    l = 0.0_wp
    m = 0.0_wp

    do z = mz, pz
       do x = mx, px

          r_x = G%metricx(x, i, z, 2)
          r_y = G%metricy(x, i, z, 2)
          r_z = G%metricz(x, i, z, 2)

          norm = sqrt(r_x**2.0_wp + r_y**2.0_wp + r_z**2.0_wp)

          ! outward unit vectors
          n(1) = r_x/norm
          n(2) = r_y/norm
          n(3) = r_z/norm

          ! compute two other orthogonal vectors, l, m
          call gen_orth_vectors(l, m, n)

          B%n_n(x, z, 1) = n(1)
          B%n_n(x, z, 2) = n(2)
          B%n_n(x, z, 3) = n(3)

          B%n_m(x, z, 1) = m(1)
          B%n_m(x, z, 2) = m(2)
          B%n_m(x, z, 3) = m(3)

          B%n_l(x, z, 1) = l(1)
          B%n_l(x, z, 2) = l(2)
          B%n_l(x, z, 3) = l(3)

       end do
    end do
  end subroutine  Local_orth_vectors_r

  subroutine local_orth_vectors_s(i, G, B)

    use mpi3dbasic, only : rank
    use datatypes, only: block_grid_t, block_boundary

    type(block_boundary),intent(inout) :: B
    type(block_grid_t),intent(in) :: G
    integer, intent(in) :: i
    integer :: mx, my, px, py
    real(kind = wp), dimension(1:3) :: l, m, n  !< three local othogonal vectors
    integer :: x, y
    real(kind = wp) :: norm, s_x, s_y, s_z

    mx = G%C%mq
    my = G%C%mr
    px = G%C%pq
    py = G%C%pr

    l(:) = 0.0_wp
    m(:) = 0.0_wp

    do y = my, py
       do x = mx, px

          s_x = G%metricx(x, y, i, 3)
          s_y = G%metricy(x, y, i, 3)
          s_z = G%metricz(x, y, i, 3)

          norm = sqrt(s_x**2.0_wp + s_y**2.0_wp + s_z**2.0_wp)

          ! outward unit vectors
          n(1) = s_x/norm
          n(2) = s_y/norm
          n(3) = s_z/norm

          ! compute two other orthogonal vectors, l, m
          call gen_orth_vectors(l, m, n)

          B%n_n(x, y, 1) = n(1)
          B%n_n(x, y, 2) = n(2)
          B%n_n(x, y, 3) = n(3)

          B%n_m(x, y, 1) = m(1)
          B%n_m(x, y, 2) = m(2)
          B%n_m(x, y, 3) = m(3)

          B%n_l(x, y, 1) = l(1)
          B%n_l(x, y, 2) = l(2)
          B%n_l(x, y, 3) = l(3)

       end do
    end do
  end subroutine  Local_orth_vectors_s

  subroutine local_orth_vectors(i, G, B)
    !subroutine Local_Orth_Vectors(G%metricx, X_y, X_z, X_l, X_m, X_n, &
    !mby, mbz, pby, pbz, my, mz, py, pz)

    use mpi3dbasic, only : rank
    use datatypes, only: block_grid_t, block_boundary
    ! Compute local orthogonal unit vectors
    type(block_boundary),intent(inout) :: B
    type(block_grid_t),intent(in) :: G
    integer, intent(in) :: i
    integer :: my, mz, py, pz
    real(kind = wp), dimension(1:3) :: l, m, n  !< three local othogonal vectors

    integer :: y, z
    real(kind = wp) :: norm, q_x, q_y, q_z

    my = G%C%mr
    mz = G%C%ms
    py = G%C%pr
    pz = G%C%ps

    l(:) = 0.0_wp
    m(:) = 0.0_wp

    do z = mz, pz
       do y = my, py

          q_x = G%metricx(i, y, z, 1)
          q_y = G%metricy(i, y, z, 1)
          q_z = G%metricz(i, y, z, 1)

          norm = sqrt(q_x**2.0_wp + q_y**2.0_wp + q_z**2.0_wp)

          ! outward unit vectors
          n(1) = q_x/norm
          n(2) = q_y/norm
          n(3) = q_z/norm

          ! compute two other orthogonal vectors, l, m
          call gen_orth_vectors(l, m, n)

          B%n_n(y, z, 1) = n(1)
          B%n_n(y, z, 2) = n(2)
          B%n_n(y, z, 3) = n(3)

          B%n_m(y, z, 1) = m(1)
          B%n_m(y, z, 2) = m(2)
          B%n_m(y, z, 3) = m(3)

          B%n_l(y, z, 1) = l(1)
          B%n_l(y, z, 2) = l(2)
          B%n_l(y, z, 3) = l(3)

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

       end do
    end do
    !     stop
  end subroutine  Local_Orth_Vectors

  subroutine  gen_orth_vectors(l, m, n)

    real(kind = wp), dimension(:), intent(in) :: n
    real(kind = wp), dimension(:), intent(inout) :: l, m
    real(kind = wp) :: tol, diff_norm1, diff_norm2

    tol = 1.0e-12_wp

    m(1) = 0.0_wp
    m(2) = 1.0_wp
    m(3) = 0.0_wp

    if (abs(sqrt(n(1)**2.0_wp+n(2)**2+n(3)**2.0_wp)-1.0_wp) .ge. tol) stop 'input vector must be a unit vector'

    diff_norm1 = sqrt((n(1)-m(1))**2.0_wp + (n(2)-m(2))**2.0_wp + (n(3)-m(3))**2.0_wp)

    diff_norm2 = sqrt((n(1)+m(1))**2.0_wp + (n(2)+m(2))**2.0_wp + (n(3)+m(3))**2.0_wp)

    if (diff_norm1 .ge. tol .and. diff_norm2 .ge. tol) then

       call Gram_Schmidt(n, m)

    else
       m(1) = 0.0_wp
       m(2) = 0.0_wp
       m(3) = 1.0_wp
       call Gram_Schmidt(n, m )

    end if

    l(1) = n(2)*m(3)-n(3)*m(2)
    l(2) = n(3)*m(1)-n(1)*m(3)
    l(3) = n(1)*m(2)-n(2)*m(1)

  end subroutine gen_orth_vectors

  subroutine Gram_Schmidt(y, z)

    ! Gram Schmidt orthonormalization

    real(kind = wp), dimension(:), intent(in) :: y
    real(kind = wp), dimension(:), intent(inout) :: z

    real(kind = wp) :: a_yz

    a_yz = y(1)*z(1) + y(2)*z(2) + y(3)*z(3)
    z = z - a_yz*y
    z = 1.0_wp/sqrt(z(1)**2.0_wp + z(2)**2.0_wp + z(3)**2.0_wp)*z

  end subroutine Gram_Schmidt

end module unit_normals


   Module MP2
   Use Precision
   Use Constants
   Use HEG

   Contains

      Subroutine DrvMBPT(Fock,T2aaaa,T2abab,T2abba,NOcc,NBF,ESCF,ECorr)
      Implicit None
      Integer,        Intent(In)  :: NOcc, NBF
      Real (Kind=pr), Intent(In)  :: ESCF
      Real (Kind=pr), Intent(In)  :: Fock(NBF)
      Real (Kind=pr), Intent(Out) :: T2aaaa(NOcc,NOcc,NOcc+1:NBF)
      Real (Kind=pr), Intent(Out) :: T2abab(NOcc,NOcc,NOcc+1:NBF)
      Real (Kind=pr), Intent(Out) :: T2abba(NOcc,NOcc,NOcc+1:NBF)
      Real (Kind=pr), Intent(Out) :: ECorr
      Real (Kind=pr) :: V_ijab, V_ijba, Denom
      Integer :: I, J, A, B

!==========================================!
!  This does the MP2 calculation.  Glory!  !
!==========================================!

      Write(6,*) "Doing MBPT2..."
      T2abab = Zero
      T2abba = Zero
      T2aaaa = Zero
      ECorr = Zero
      Do I = 1,NOcc
      Do J = 1,NOcc
      Do A = NOcc+1,NBF
        B = FindIndex(I,J,A)
        If(B <= NOcc) Cycle
        V_ijab = ERI(I,J,A,B)
        V_ijba = ERI(I,J,B,A)
        If(Min(V_ijab,V_ijba) < -80.0_pr) Then
          Print *, "Disallowed excitation not trapped!"
          Cycle
        End If
        Denom = Fock(I) + Fock(J) - Fock(A) - Fock(B)
        T2abab(I,J,A) =  V_ijab/Denom
        T2abba(I,J,A) = -V_ijba/Denom
        T2aaaa(I,J,A) =  T2abab(I,J,A) + T2abba(I,J,A)
        ECorr = ECorr                                                &
              + F12*T2aaaa(I,J,A)*(ERI(I,J,A,B) - ERI(I,J,B,A))      &
              + F12*T2abab(I,J,A)*ERI(I,J,A,B)                       &
              - F12*T2abba(I,J,A)*ERI(I,J,B,A)
      End Do
      End Do
      End Do

! Write to Output and we're done!
      Open(7,File='Output',Position="Append")
      Write(7,1000)
      Write(7,1005) ESCF
      Write(7,1040)
      Write(7,1030)
      Write(7,1040)
      Do I = 1,NOcc
        Write(7,1050) Fock(I)
      End Do
      Write(7,1060)
      Do A = NOcc+1,NBF
        Write(7,1050) Fock(A)
      End Do
      Write(7,1000)
      Write(7,1010) ECorr
      Write(7,1020) ECorr + ESCF
      Write(7,1000)
      Close(7)

1000  Format(14x,'**************************************************')
1005  Format(14x,'* E(SCF) is ',12x,F18.12,' a.u.',2x,'*')
1010  Format(14x,'* E(2) is ',14x,F18.12,' a.u.',2x,'*')
1020  Format(14x,'* E(SCF) + E(2) is ',5x,F18.12,' a.u.',2x,'*')
1030  Format(14X,'*                RHF Eigenvalues:                *')
1040  Format(14x,'*------------------------------------------------*')
1050  Format(14x,'*',12x,ES24.16,12x,'*')
1060  Format(14x,'*',12x,24("-"),12x,'*')

      Return
      End Subroutine DrvMBPT

   End Module MP2