!*robodoc*m* CGPACK/cgca_m2phys
!  NAME
!    cgca_m2phys
!  SYNOPSIS

!$Id: cgca_m2phys.f90 530 2018-03-26 16:10:00Z mexas $

module cgca_m2phys

!  DESCRIPTION
!    Module dealing with physical units - length and time.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  CONTAINS
!    cgca_cadim, cgca_gdim, cgca_imco
!  USES
!    cgca_m1co
!  USED BY
!    perhaps the user directly?
!  SOURCE

use cgca_m1co, only: idef, iarr, rdef
implicit none

private
public :: cgca_gdim, cgca_cadim, cgca_imco

contains

!*roboend*

!*robodoc*s* cgca_m2phys/cgca_gdim
!  NAME
!    cgca_gdim
!  SYNOPSIS

subroutine cgca_gdim( n, ir, qual )

!  INPUT

integer( kind=idef ), intent( in ) :: n

!  OUTPUT

integer( kind=idef ), intent( out ) :: ir(3)
real( kind=rdef ), intent( out ) :: qual

!  SIDE EFFECTS
!    None
!  DESCRIPTION
!    The purpose of this routine is to find 3 coarray
!    grid dimensions, ir(1) >= ir(2) >= ir(3),
!    such that for a given number of images
!    the coarray grid is as "cubic" as possible.
!    In mathematical terms the aim is to find
!    F = min( max( ir(1) - ir(3) ) ).
!    The quality of this minimum is defined as QUAL=1-F/(N-1).
!    Inputs:
!    - N is the total number of images, num_images().
!    Outputs:
!    - ir - the array of 3 coarray grid dimensions.
!    - qual - is the quality of the fitted grid.
!      qual=1 means F=0, i.e. the coarray grid is a cube.
!      qual=0 means F=N-1, i.e. the coarray grid is 1D, i.e. [N,1,1].
!    The outputs of this routine, ir, are used to choose
!    the dimensions of space coarray.
!    The QUAL output is for information only.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  NOTES
!    If N<1 is given, then the routine returns immediately
!    with QUAL=-1. So the caller can/should check for this condition.
!  USES
!  USED BY
!    Supposed to be called prior to calling cgca_cadim
!  SOURCE

real( kind=rdef ), parameter :: one = 1.0_rdef, zero = 0.0_rdef, &
  third = one/3.0_rdef
integer( kind=idef) :: i, j, k, f, ftrial

! default output
  ir(1) = n
ir(2:3) = 1
   qual = zero

! return immediately if n=1
if ( n .eq. 1 ) return

! return with QUAL=-1 if N<1
if ( n .lt. 1 ) then
  qual = -one
  return
end if

! Set the initial value of the objective function
f = n-1

loopi1: do i = n/2, int( real(n)**third ), -1
          if ( mod( n,i ) .ne. 0 ) cycle loopi1
loopi2:   do j = n/i, 2, -1
            if ( j .gt. i ) cycle loopi2
            if ( mod( n,(i*j) ) .ne. 0 ) cycle loopi2
            k = n/(i*j)
            if ( k .gt. j ) cycle loopi2
            ftrial = i-k
            if ( ftrial .ge. f ) cycle loopi2
            f = ftrial
            ir(1) = i
            ir(2) = j
            ir(3) = k
            if ( f .eq. 0 ) exit loopi1
          end do loopi2
        end do loopi1

qual = one - real(f)/(n-one)

end subroutine cgca_gdim

!*roboend*

!*robodoc*s* cgca_m2phys/cgca_cadim
!  NAME
!    cgca_cadim
!  SYNOPSIS

subroutine cgca_cadim( bsz, res, dm, ir, c, lres, ng )

!  INPUT

real( kind=rdef ), intent( inout ) :: bsz(3)
real( kind=rdef ), intent( in ) :: res, dm
integer, intent( inout ) :: ir(3)

!  OUTPUT

integer, intent( out ) :: c(3), ng
real( kind=rdef ), intent( out ) :: lres

!  SIDE EFFECTS
!    Arrays bsz and ir are input/output. On exit the values of ir are
!    rearranged. The values of bsz are changed.
!  DESCRIPTION
!    Inputs:
!    - bsz - box size, the size of the CA space in physical
!      units of length. The unit itself is not defined.
!      It's use must be consistent across the whole of
!      CGPACK. In particular, speeds will depend on the choice
!      of the length unit.
!    - res - the model resolution, cells per grain. Note that
!      this is *not* spatial resolution. The meaning is that
!      RES cells are required to resolve the shape of a grain.
!      This setting should not depend on the grain size.
!    - dm - the mean grain size, in physical units.
!    - ir - coarray grid dimensions. The intention is that ir
!      is calculate by a call to cgca_gdim.
!    Outputs:
!    - ir - rearranged coarray grid dimensions
!    - bsz - new box dimension is calculated, see note 3.
!    - c - numbers of cells in the space coarray
!    - lres - linear resolution, cells per unit of length
!    - ng - number of grains in the whole model
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  NOTES
!    1. The space coarray should be declared with something like this
!         space( c(1), c(2), c(3), nlayers )[ir(1),ir(2),*]
!    on all images.
!
!    2. An important feature is that the coarray grid
!    dimensions can be rearranged to better suit the physical
!    dimensions of the "box". For example, on input ir(1)
!    is the biggest. However, if the physical dimension of
!    the box is smallest along 1, it makes sense to swap
!    ir(1) with ir(3). This will help achive balanced
!    linear resolution along each dimension.
!
!    3. It not generally possible to have the same
!    linear resolution is all 3 directions and to keep
!    the physical size of the box exactly as given.
!    The decision is made here to give preference to
!    the linear resolution. So the algorithm chooses
!    the same linear resolution in all 3 directions.
!    As a consequence, the physical sizes of the box
!    along all 3 directions can be slightly smaller or
!    bigger than given. The biggest deviations probably
!    arise when the shape is very far from cubic.
!  USES
!  USED BY
!    via module cgca_m2phys
!  SOURCE

real( kind=rdef ), parameter :: one = 1.0_rdef, third = one/3.0_rdef
real( kind=rdef ) :: &
 bvol,               & ! "box" volume in physical units
 dm3                   ! dm**3

! Derived type for easy sorting
type bsz_order
  real( kind=rdef ) :: bsz
  integer :: i
end type bsz_order

type( bsz_order ) :: box(3), tmp

! Assume that ir is already sorted in decreasing order,
! as returned by cgca_gdim. Check this assertion.
if ( ir(1) .lt. ir(2) .or. ir(2) .lt. ir(3) .or. ir(1) .lt. ir(3) ) then
  write (*,*) "ERROR: cgca_m2phys/cgca_cadim: ir is not sorted on entry"
  error stop
end if

! Set the initial descending order, 1 to 3
box(1) = bsz_order( bsz(1), 1 )
box(2) = bsz_order( bsz(2), 2 )
box(3) = bsz_order( bsz(3), 3 )

!write (*,*) "ir on entry:", ir
!write (*,*) "box:", box

! Now sort box%bsz in decreasing order and the resulting order
! or box%i is what I need.

if ( box(1)%bsz .lt. box(2)%bsz ) then
     tmp = box(1)
  box(1) = box(2)
  box(2) = tmp
end if

if ( box(2)%bsz .lt. box(3)%bsz ) then
     tmp = box(2)
  box(2) = box(3)
  box(3) = tmp
end if

if ( box(1)%bsz .lt. box(2)%bsz ) then
     tmp = box(1)
  box(1) = box(2)
  box(2) = tmp
end if

! Reassign elements in desired order
ir( box%i ) = ir

!write (*,*) "ir on exit:", ir

! box volume
bvol = bsz(1)*bsz(2)*bsz(3)

! grain volume
dm3 = dm**3

! number of grains in the whole model, integer
ng = int( bvol/dm3 )

! linear resolution
! res**third      - cells per mean grain size length, dm
! res**third / dm - cells per unit length
lres = res**third / dm

! numbers of cells
! res**third/dm * bsz(i)       - cells per box length along i
! res**third/dm * bsz(i)/ir(i) - cells per image along i
c = nint( lres * bsz/ir )

! cannot have zero as the array dimension
if ( c(1) .eq. 0 ) c(1) = 1
if ( c(2) .eq. 0 ) c(2) = 1
if ( c(3) .eq. 0 ) c(3) = 1

! warn the user, the box is likely to be very different
! from the input values.
if ( any( c .eq. 1 ) ) then
  write (*,"(a)")                                                      &
   "WARN: cgca_cadim: the new box sizes are probably wrong, check"
end if

! new box size
bsz = real( ir*c, kind=rdef ) / lres

end subroutine cgca_cadim

!*roboend*

!*robodoc*s* cgca_m2phys/cgca_imco
!  NAME
!    cgca_imco
!  SYNOPSIS

subroutine cgca_imco( space, lres, bcol, bcou )

!  INPUT

integer( kind=iarr ), allocatable, intent( in ) :: &
 space(:,:,:,:)[:,:,:]
real( kind=rdef ), intent( in ) :: lres

!  OUTPUT

real( kind=rdef ), intent( out ) :: bcol(3), bcou(3)

!  DESCRIPTION
!    IMCO stands for IMage COordinates. This routine calculates
!    the lower and the upper physical coordinates of the
!    coarray on this image in CA CS.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  INPUTS
!    - space - the model coarray. Error will result if it's
!      not allocated. The array is used only to calculate the
!      position of this image within the coarray grid, as
!       this_image( space )
!    - lres - linear resolution of the space cooarray,
!      cells per unit of length.
!  OUTPUTS
!    - bcol - physical coordinates of the lower bounds of the coarray
!      on this image in CA CS.
!    - bcou - physical coordinates of the upper bounds of the coarray
!      on this image in CA CS.
!  SIDE EFFECTS
!      none

real( kind=rdef ) :: one = 1.0_rdef, half = 0.5_rdef

integer( kind=idef ) :: &
 img(3),                & ! the coarray image grid is always 3D
 szsp(3)                  ! size of the space array, on one image!

real( kind=rdef) :: hcsz  ! half of the cell physical size

! this image index
img = this_image( space )

! Size of the space array.
! Remember that space array has 1 halo cell on each
! boundary along each dimension. Don't count those:
szsp(1) = size( space, dim=1 ) - 2_idef
szsp(2) = size( space, dim=2 ) - 2_idef
szsp(3) = size( space, dim=3 ) - 2_idef

! vectors in CA CS
bcol = real( ((img-1) * szsp(1:3) + 1), kind=rdef) / lres
bcou = real( img * szsp(1:3), kind=rdef ) / lres

! Make sure there are no gaps between the upper
! and the next lower boundary. The gap equals to the
! physical size of a single cell. So add half a cell size
! to the upper boundary and subtract half a cell size from
! the lower boundary.
hcsz = half * ( one / lres )
bcol = bcol - hcsz
bcou = bcou + hcsz

end subroutine cgca_imco

!*roboend*

!*********************************************************************72

end module cgca_m2phys


*DECK CLNREL
      COMPLEX FUNCTION CLNREL (Z)
C***BEGIN PROLOGUE  CLNREL
C***PURPOSE  Evaluate ln(1+X) accurate in the sense of relative error.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      COMPLEX (ALNREL-S, DLNREL-D, CLNREL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CLNREL(Z) = LOG(1+Z) with relative error accuracy near Z = 0.
C Let   RHO = ABS(Z)  and
C       R**2 = ABS(1+Z)**2 = (1+X)**2 + Y**2 = 1 + 2*X + RHO**2 .
C Now if RHO is small we may evaluate CLNREL(Z) accurately by
C       LOG(1+Z) = CMPLX  (LOG(R), CARG(1+Z))
C                 = CMPLX  (0.5*LOG(R**2), CARG(1+Z))
C                 = CMPLX  (0.5*ALNREL(2*X+RHO**2), CARG(1+Z))
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNREL, CARG, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  CLNREL
      COMPLEX Z
      SAVE SQEPS
      DATA SQEPS /0.0/
C***FIRST EXECUTABLE STATEMENT  CLNREL
      IF (SQEPS.EQ.0.) SQEPS = SQRT (R1MACH(4))
C
      IF (ABS(1.+Z) .LT. SQEPS) CALL XERMSG ('SLATEC', 'CLNREL',
     +   'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR -1', 1, 1)
C
      RHO = ABS(Z)
      IF (RHO.GT.0.375) CLNREL = LOG (1.0+Z)
      IF (RHO.GT.0.375) RETURN
C
      X = REAL(Z)
      CLNREL = CMPLX (0.5*ALNREL(2.*X+RHO**2), CARG(1.0+Z))
C
      RETURN
      END


PROGRAM Driver

  USE KindModule, ONLY: &
    DP, Zero, SqrtTiny, One
  USE GeometryFieldsModule, ONLY: &
    nGF, &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33
  USE RadiationFieldsModule, ONLY: &
    nCR
  USE TwoMoment_CharacteristicDecompositionModule, ONLY: &
    TwoMoment_ComputeCharacteristicDecomposition

  IMPLICIT NONE

  INTEGER  :: iDim
  REAL(DP) :: G(nGF)
  REAL(DP) :: U(nCR)
  REAL(DP) :: R(nCR,nCR)
  REAL(DP) :: invR(nCR,nCR)
  REAL(DP) :: TestMatrix(nCR,nCR)

  REAL(DP) :: D, I_1, I_2, I_3, Gm_dd_11, Gm_dd_22, Gm_dd_33

  WRITE(*,*)
  WRITE(*,'(A4,A)')'', 'Running CharacteristicDecomposition Test'

  ! ComputeFluxJacobian test in x:

  iDim = 1
  D        = 5.d0 * SqrtTiny!5.0d-1
  I_1      = SqrtTiny!1.0d-1
  I_2      = Zero
  I_3      = Zero
  Gm_dd_11 = One
  Gm_dd_22 = One
  Gm_dd_33 = One

  G(iGF_Gm_dd_11) = Gm_dd_11
  G(iGF_Gm_dd_22) = Gm_dd_22
  G(iGF_Gm_dd_33) = Gm_dd_33

  U = [ D, I_1, I_2, I_3 ]

  WRITE(*,*)
  WRITE(*,'(A4,4A18)') '', ' J', 'H1', 'H2', 'H3'
  WRITE(*,'(A4,4ES18.3)') '', D, I_1, I_2, I_3

  CALL TwoMoment_ComputeCharacteristicDecomposition &
         ( iDim, G, U, R, invR )

  ! ComputeFluxJacobian test in y:

  iDim = 2
  D        = 5.d0 * SqrtTiny!5.0d-1
  I_1      = Zero
  I_2      = SqrtTiny
  I_3      = Zero

  U = [D, I_1, I_2, I_3]

  WRITE(*,*)
  WRITE(*,'(A4,4A18)') '', ' J', 'H1', 'H2', 'H3'
  WRITE(*,'(A4,4ES18.3)') '', D, I_1, I_2, I_3

  CALL TwoMoment_ComputeCharacteristicDecomposition &
         ( iDim, G, U, R, invR )

  ! ComputeFluxJacobian test in z:

  iDim = 3
  D        = 5.d0 * SqrtTiny!5.0d-1
  I_1      = Zero
  I_2      = Zero
  I_3      = SqrtTiny

  U = [ D, I_1, I_2, I_3 ]

  WRITE(*,*)
  WRITE(*,'(A4,4A18)') '', ' J', 'H1', 'H2', 'H3'
  WRITE(*,'(A4,4ES18.3)') '', D, I_1, I_2, I_3

  CALL TwoMoment_ComputeCharacteristicDecomposition &
         ( iDim, G, U, R, invR )

END PROGRAM Driver


!
!     ------------------------------------------------------------------
!     B N D I N V
!     ------------------------------------------------------------------
!
      SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE)
!
!       DOUBLE PRECISION MATRIX INVERSION SUBROUTINE
!       FROM "DLYTAP".
!
!*      DOUBLE PRECISION E,F
!*      DOUBLE PRECISION A,EL,D,DSQRT,C,S,DETERP
!-----------------------------------------------
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:08:49   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(OUT) :: ITEST
      INTEGER , INTENT(IN) :: NSIZE
      REAL(DOUBLE) , INTENT(OUT) :: DETERM
      REAL(DOUBLE) , INTENT(IN) :: EPSIL
      REAL(DOUBLE) , INTENT(INOUT) :: A(NSIZE,NSIZE)
      REAL(DOUBLE) , INTENT(INOUT) :: EL(NSIZE,NSIZE)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: ISL2, K000FX, INDSNL, I, J, N1, M, K, J1, I1, KS
      REAL(DOUBLE) :: D, C, S, DETERP, F, E, EPSILP, RAT
!-----------------------------------------------
      IF (N < 2) GO TO 140
      ISL2 = 0
      K000FX = 2
      IF (ISL2 == 0) INDSNL = 2
      IF (ISL2 == 1) INDSNL = 1
!       CALL SLITET(2,INDSNL)
!       CALL OVERFL(K000FX)
!       CALL DVCHK(K000FX)
!
!       SET EL = IDENTITY MATRIX
      DO I = 1, N
         EL(I,:N) = 0.0D0
         EL(I,I) = 1.0D0
      END DO
!
!       TRIANGULARIZE A, FORM EL
!
      N1 = N - 1
      M = 2
      DO J = 1, N1
         DO I = M, N
            IF (A(I,J) == 0.0D0) CYCLE
            D = DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J))
            C = A(J,J)/D
            S = A(I,J)/D
            DO K = J, N
               D = C*A(J,K) + S*A(I,K)
               A(I,K) = C*A(I,K) - S*A(J,K)
               A(J,K) = D
            END DO
            DO K = 1, N
               D = C*EL(J,K) + S*EL(I,K)
               EL(I,K) = C*EL(I,K) - S*EL(J,K)
               EL(J,K) = D
            END DO
         END DO
         M = M + 1
      END DO
!       CALL OVERFL(K000FX)
!       GO TO (140,51),K000FX
!
!       CALCULATE THE DETERMINANT
      DETERP = A(1,1)
      DO I = 2, N
         DETERP = DETERP*A(I,I)
      END DO
      DETERM = DETERP
!       CALL OVERFL(K000FX)
!       GO TO (140,520,520),K000FX
!
!       IS MATRIX SINGULAR
      F = A(1,1)
      E = A(1,1)
      DO I = 2, N
         IF (DABS(F) < DABS(A(I,I))) F = A(I,I)
         IF (DABS(E) <= DABS(A(I,I))) CYCLE
         E = A(I,I)
      END DO
      EPSILP = EPSIL
      IF (EPSILP <= 0) EPSILP = 1.0E-8
      RAT = E/F
      IF (ABS(RAT) < EPSILP) GO TO 130
!
!       INVERT TRIANGULAR MATRIX
      J = N
      DO J1 = 1, N
!       CALL SLITE(2)
         I = J
         ISL2 = 1
         DO I1 = 1, J
!       CALL SLITET(2,K000FX)
            IF (ISL2 == 0) K000FX = 2
            IF (ISL2 == 1) THEN
               K000FX = 1
               ISL2 = 0
            ENDIF
            SELECT CASE (K000FX)
            CASE DEFAULT
               A(I,J) = 1.0D0/A(I,I)
            CASE (2)
               KS = I + 1
               D = 0.0D0
               D = SUM(A(I,KS:J)*A(KS:J,J))
               A(I,J) = -D/A(I,I)
            END SELECT
 1003       CONTINUE
            I = I - 1
         END DO
         J = J - 1
      END DO
!       CALL OVERFL(K000FX)
!       GO TO (140,103,103),K000FX

!103    CALL DVCHK(K000FX)
!       GO TO (140,105),K000FX
!
!       PREMULTIPLY EL BY INVERTED TRIANGULAR MATRIX
      M = 1
      DO I = 1, N
         DO J = 1, N
            D = 0.0D0
            D = SUM(A(I,M:N)*EL(M:N,J))
            EL(I,J) = D
         END DO
         M = M + 1
      END DO
!       CALL OVERFL(K000FX)
!       GO TO (140,123,123),K000FX
!
!       RECOPY EL TO A
      A(:N,:N) = EL(:N,:N)
      ITEST = 0
!126    IF(INDSNL.EQ.1)CALL SLITE(2)
  126 CONTINUE
      IF (INDSNL == 1) ISL2 = 1
      RETURN
!
  130 CONTINUE
      ITEST = 1
      GO TO 126
  140 CONTINUE
      ITEST = -1
      GO TO 126
      END SUBROUTINE BNDINV


c Saturation vapor pressure and mixing ratio.
c Based on Flatau et.al, (JAM, 1992:1507)
c

	real function esatw(t)
	real t	! temperature (K)
	data a0,a1,a2,a3,a4,a5,a6,a7,a8 /
     *	6.105851, 0.4440316, 0.1430341e-1,
     *  0.2641412e-3, 0.2995057e-5, 0.2031998e-7,
     *  0.6936113e-10, 0.2564861e-13,-0.3704404e-15/
c     *	6.11239921, 0.443987641, 0.142986287e-1,
c     *  0.264847430e-3, 0.302950461e-5, 0.206739458e-7,
c     *  0.640689451e-10, -0.952447341e-13,-0.976195544e-15/
        dt = max(-80.,t-273.16)
	esatw = a0 + dt*
     &       (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*
     &          (a6+dt*(a7+a8*dt)))))))
        return
        end

        real function qsatw(t,p)
	real t	! temperature (K)
	real p	! pressure    (mb)
	real esat
	esat=esatw(t)
        qsatw=0.622*esat/(p-esat)
        return
        end

        real function dtesatw(t)
	real t	! temperature (K)
	data a0,a1,a2,a3,a4,a5,a6,a7,a8 /
     &  0.443956472, 0.285976452e-1, 0.794747212e-3,
     &  0.121167162e-4, 0.103167413e-6, 0.385208005e-9,
     &  -0.604119582e-12, -0.792933209e-14, -0.599634321e-17/
        dt = max(-80.,t-273.16)
	dtesatw = a0 + dt*
     &       (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*
     &          (a6+dt*(a7+a8*dt)))))))
        return
        end

        real function dtqsatw(t,p)
	real t	! temperature (K)
	real p	! pressure    (mb)
        dtqsatw=0.622*dtesatw(t)/p
        return
        end

	real function esati(t)
	real t	! temperature (K)
	data a0,a1,a2,a3,a4,a5,a6,a7,a8 /
     &	6.11147274, 0.503160820, 0.188439774e-1,
     &  0.420895665e-3, 0.615021634e-5,0.602588177e-7,
     &  0.385852041e-9, 0.146898966e-11, 0.252751365e-14/
        dt = max(-80.,t-273.16)
	esati = a0 + dt*
     &       (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*
     &          (a6+dt*(a7+a8*dt)))))))
        return
        end

        real function qsati(t,p)
	real t	! temperature (K)
	real p	! pressure    (mb)
	real esat
	esat=esati(t)
        qsati=0.622*esat/(p-esat)
        return
        end

        real function dtesati(t)
	real t	! temperature (K)
	data a0,a1,a2,a3,a4,a5,a6,a7,a8 /
     &	0.503223089, 0.377174432e-1,0.126710138e-2,
     &	0.249065913e-4, 0.312668753e-6, 0.255653718e-8,
     &	0.132073448e-10, 0.390204672e-13, 0.497275778e-16/
        dt = max(-80.,t-273.16)
	dtesati = a0 + dt*
     &       (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*
     &          (a6+dt*(a7+a8*dt)))))))
        return
        end

        real function dtqsati(t,p)
	real t	! temperature (K)
	real p	! pressure    (mb)
        dtqsati=0.622*dtesati(t)/p
        return
        end


      MODULE m_rcerf
      use m_juDFT
c*********************************************************************
c     calculates  real( erf(x+iy) ) for z=x+iy in the first quadrant.
c             m. weinert   may 1987
c     new declaration part
c                       s. bl"ugel, IFF, Nov.97

      PRIVATE
      PUBLIC rcerf
      CONTAINS
c*********************************************************************
      REAL FUNCTION rcerf(x,y)
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      REAL    x,y
C     ..
C     .. Local Scalars ..
      COMPLEX z
      REAL wr,wi
c
      z = cmplx(x,y)
c
c--->    calculate w(z')=exp(-z'**2)*erfc(-iz') for -iz'=z
c
      CALL wofz(y,x,wr,wi)
c
c--->    erf(x+iy)=1-exp(-z**2)*conjg( w(y+ix) )
c
      RCERF = 1.0 - real( exp( -z*z ) * cmplx( wr,-wi ) )

      END FUNCTION rcerf

c*********************************************************************
      SUBROUTINE wofz(x,y,wr,wi)
c     calculates  w(z) = exp(-z**2) erfc(-iz)   for z = x + iy in the
c     first quadrant of the complex plane. based on acm algorithm 363
c     by w. gautschi, comm. acm 12, 635 (1969). the accuracy is about
c     10**-10.
c                       m. weinert    may 1987
c     new declaration part
c                       s. bl"ugel, IFF, Nov.97
c*********************************************************************
      USE m_constants
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      REAL    x,y,wr,wi
C     ..
C     .. Local Scalars ..
      INTEGER icap,nu,n
      REAL    c,h,h2,plam,r1,r2,s,s1,s2,tsqpi,t1,t2
      LOGICAL bol

c--->    2/sqrt(pi) required for the normalization
      tsqpi = 2.0/sqrt(pi_const)
c
c--->    stop if not in first quadrant
      IF ( x<0.0 .OR. y<0 )  CALL juDFT_error("wofz",calledby ="rcerf")
c
      IF ( y.LT.4.29 .AND. x.LT.5.33 ) THEN
        s=(1.-y/4.29)*sqrt(1.-x*x/28.41)
        h=1.6*s
        h2=2*h
        icap=6+23*s
        nu=9+21*s
        plam=h2**icap
        bol=.true.
      ELSE
        h=0.0
        icap=0
        nu=8
        bol=.false.
      END IF
c
      r1=0.0
      r2=0.0
      s1=0.0
      s2=0.0
      DO n = nu,0,-1
         t1=y+h+(n+1)*r1
         t2=x-(n+1)*r2
         c=0.5/(t1*t1+t2*t2)
         r1=c*t1
         r2=c*t2
         IF ( bol .AND. n.LE.icap ) then
           t1=plam+s1
           s1=r1*t1-r2*s2
           s2=r2*t1+r1*s2
           plam=plam/h2
         END IF
      ENDDO
      IF ( bol ) THEN
        wr=tsqpi*s1
        wi=tsqpi*s2
      ELSE
        wr=tsqpi*r1
        wi=tsqpi*r2
      END IF
      IF ( y.EQ.0.0 ) wr=exp(-x*x)

      END SUBROUTINE wofz

      END MODULE m_rcerf


c=======================================================================
c
c     subroutine CHOL
c
c     Choleski factorization of a symmetric and definite matrix:
c
c     X = L*L', where L is an lower triangular matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE chol ( n, X, dwork, L, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : size of matrix X                           integer
c            X      : symmetric matrix (n*n)                      double
c
c     WORKSPACE
c            dwork  : vector (n*n)                                double
c
c     OUTPUT
c            L      : lower triangular matrix (n*n)               double
c            info   : diagnostic argument                        integer
c
c     CALL
c            YM     : copy a vectorized matrix in a vectorized matrix
c            DPOTRF : Choleski factorization (cf. LAPACK)
c            CMCML  : converting a full square matrix (n*n)
c                    in low triangular matrix (n*n)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION X(*), L(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pmat
c
c     external subroutines
      EXTERNAL YM, DPOTRF, CMCML
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pmat = 1
c     pmat  : pointer for vectorized symmetric matrix, so (n*n) more
c
c     Total size of dwork array = (n*n)
c
c-----------------------------------------------------------------------
c
c     saves matrix initial ( altered by DPOTRF )
      CALL YM ( n, n, x, dwork(pmat) )
c
c     Choleski factorization (cf. LAPACK)
      CALL DPOTRF ( 'L', n, dwork(pmat), n, info )
      IF (info .ne. 0) RETURN
c
c     conversion in low triangular matrix
      CALL CMCML ( n, dwork(pmat), L)
c
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Calculate ANGLN, ANGLA, and ANGLB from the C-matrix, spin vector,
C and spacecraft vector.
C
C Inputs: CM,N,PSC,SCLON,RLORA
C Outputs: ANGLN,ANGLA,ANGLB
C
      SUBROUTINE GETANGLES(CM,N,PSC,angln,angla,anglb)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 CM(3,3),N(3),PSC(3)
      REAL*8 N0(3),P0(3),P1(3),NX,NZ
      COMMON/CONST/PI,DTR,RTD
C
C        Rotate spin vector N and S/C vector PSC into image space by
C        multiplying by CM-inverse.
      DO I=1,3
         N0(I) = CM(1,I)*N(1) + CM(2,I)*N(2) + CM(3,I)*N(3)
         P0(I) = CM(1,I)*PSC(1) + CM(2,I)*PSC(2) + CM(3,I)*PSC(3)
      ENDDO
C
C     ....Rotate spin vector thru ANGLN so that north is along X-axis
      ANGLN = DATAN2(N0(2),N0(1))	! Compute angle N
      NX = N0(1)*DCOS(ANGLN) + N0(2)*DSIN(ANGLN)
      NZ = N0(3)

C     ....Rotate S/C vector thru angles N and A
      ANGLA = DATAN2(NX,NZ)             ! Compute angle A
      P1(1) =  P0(1)*DCOS(ANGLN) + P0(2)*DSIN(ANGLN)
      P1(2) = -P0(1)*DSIN(ANGLN) + P0(2)*DCOS(ANGLN)
      P1(3) =  P0(3)
      PX = P1(1)*DCOS(ANGLA) - P1(3)*DSIN(ANGLA)
      PY = P1(2)
      ANGLB = DATAN2(PY,PX)		! Compute angle B
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Calculate THETA_N, THETA_A, and THETA_B for the C-matrix.  The angles
C are analoguous to ANGLN, ANGLA, and ANGLB for the OM-matrix.
C
C Input: CM
C Outputs: THETA_N,THETA_A,THETA_B
C
      SUBROUTINE GETANGLES2(CM,theta_n,theta_a,theta_b)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 CM(3,3),N(3),PSC(3)
      REAL*8 N0(3),P0(3),P1(3),NX,NZ
      COMMON/CONST/PI,DTR,RTD
C
C        In this routine, the EME50 coordinate system takes the role
C        of the planet coordinate system.
      N(1) = 0.		!Spin vector is z-axis
      N(2) = 0.
      N(3) = 1.

      PSC(1) = 1.		!Spacecraft vector is x-axis
      PSC(2) = 0.
      PSC(3) = 0.

C        Rotate spin vector N and S/C vector PSC into image space by
C        multiplying by CM-inverse.
      DO I=1,3
      N0(I) = CM(1,I)*N(1) + CM(2,I)*N(2) + CM(3,I)*N(3)
      P0(I) = CM(1,I)*PSC(1) + CM(2,I)*PSC(2) + CM(3,I)*PSC(3)
      ENDDO
C
C        Rotate spin vector thru THETA_N so that north is along X-axis
      if (n0(1).eq.0.0) then
	THETA_N = 0.5*pi
      else
	THETA_N = DATAN2(N0(2),N0(1))	! Compute angle N
      endif
      NX = N0(1)*DCOS(THETA_N) + N0(2)*DSIN(THETA_N)
      NZ = N0(3)
C         Rotate S/C vector thru angles N and A
      if (nz.eq.0.0) then
	THETA_A = 0.5*pi
      else
	THETA_A = DATAN2(NX,NZ)             ! Compute angle A
      endif
      P1(1) =  P0(1)*DCOS(THETA_N) + P0(2)*DSIN(THETA_N)
      P1(2) = -P0(1)*DSIN(THETA_N) + P0(2)*DCOS(THETA_N)
      P1(3) =  P0(3)
      PX = DCOS(THETA_A)*P1(1) - DSIN(THETA_A)*P1(3)
      PY = P1(2)
      if (px.eq.0.0) then
	THETA_B = 0.5*pi
      else
	THETA_B = DATAN2(PY,PX)		! Compute angle B
      endif
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C This routine takes an input C-matrix (C) and computes the three Euler
C angles (ALPHA,DELTA,KAPPA) representing the matrix.
C
C Outputs: ALPHA,DELTA,KAPPA: Euler angles in radians.
C
C The 9 elements of the C matrix are stored in order of increasing address
C as
C                  |  c1  c4  c7  |
C                  |  c2  c5  c8  |
C                  |  c3  c6  c9  |
C
      SUBROUTINE COMPCM(C,alpha,delta,kappa)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 C(9)	!Input C-matrix
      REAL*8 ALPHA	!Output RA of instrument boresight (degrees)
      REAL*8 DELTA	!Output Declination of instrument boresight (degrees)
      REAL*8 KAPPA	!Output rotation about optical axis (degrees)

      PI = 3.141592653589793D0
      RTD = 180.D0/PI

      if (c(7).eq.0.0) then
	ALPHA = 0.5*pi
      else
	ALPHA = DATAN2(C(8),C(7))
      endif
      DELTA = DASIN(C(9))
      if (c(6).eq.0.0) then
	KAPPA = 0.5*pi
      else
	KAPPA = DATAN2(C(3),C(6))
      endif
      IF (ALPHA.LT.0.D0) ALPHA=ALPHA+2.D0*PI
      IF (KAPPA.LT.0.D0) KAPPA=KAPPA+2.D0*PI
CCC      ALPHA = ALPHA*RTD
CCC      DELTA = DELTA*RTD
CCC      KAPPA = KAPPA*RTD
C Temporary code to test whether this works...
CCC      CALL BUILDCM(ctest,ALPHA,DELTA,KAPPA)
CCC      CALL ORTHOT(CTEST)
CCC      CALL PRNT(8,9,C,' C-matrix=.')
CCC      CALL PRNT(8,9,CTEST,' COMPCM C-matrix=.')
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to calculate the camera-to-planet rotation matrix (OM)
C from angles ANGLN, ANGLA, and ANGLB.
      SUBROUTINE OMMATRIX(ANGLN,ANGLA,ANGLB,OM)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 OM(3,3)
C
C        The OM-matrix is initially matrix M1 (north angle rotation about
C        z0-axis).
      OM(1,1) =  DCOS(ANGLN)
      OM(2,1) = -DSIN(ANGLN)
      OM(3,1) =  0.D0
C
      OM(1,2) =  DSIN(ANGLN)
      OM(2,2) =  DCOS(ANGLN)
      OM(3,2) =  0.D0
C
      OM(1,3) =  0.D0
      OM(2,3) =  0.D0
      OM(3,3) =  1.D0
C        OM = M2*M1 (rotate about y1-axis through angle A)
      DO 20 J=1,3
      TEMP    = DCOS(ANGLA)*OM(1,J) - DSIN(ANGLA)*OM(3,J)
      OM(3,J) = DSIN(ANGLA)*OM(1,J) + DCOS(ANGLA)*OM(3,J)
   20 OM(1,J) = TEMP
C        OM = M3*M2*M1 (rotate about z2-axis through angle B)
      DO 30 J=1,3
      TEMP    =  DCOS(ANGLB)*OM(1,J) + DSIN(ANGLB)*OM(2,J)
      OM(2,J) = -DSIN(ANGLB)*OM(1,J) + DCOS(ANGLB)*OM(2,J)
   30 OM(1,J) = TEMP
C
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute the C-matrix from ME and OM' matrices...
C Output: CM
C
      SUBROUTINE CMATRIX(ME,ANGLN,ANGLA,ANGLB,SCLON,CM)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 ME(3,3),CM(3,3),OMp(3,3)

C           Compute OM' matrix
      CALL OMMATRIX(ANGLN,ANGLA,ANGLB-SCLON,OMp)

      DO 150 J=1,3
      DO 150 I=1,3
  150 CM(I,J) = ME(I,1)*OMp(1,J)+ME(I,2)*OMp(2,J)+ME(I,3)*OMp(3,J)

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given a unit vector in EME50 coordinates, compute the latitude-longitude
C coordinates...
C
C Inputs: ME matrix
C         P = unit vector
C Outputs: RLAT,RLON
C
      SUBROUTINE FROMEME(ME,P,RLAT,RLON)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 ME(3,3),P(3),xdot
      COMMON/CONST/PI,DTR,RTD

      RLAT = DASIN(DOT(P,ME(1,3)))			!RLAT = P o N
      xdot = DOT(P,ME(1,1))
      if (xdot.eq.0.0) then
	RLON = 0.5*pi
      else
	RLON = DATAN2(DOT(P,ME(1,2)),xdot)
      endif
      RLON = DMOD(RLON+2.0D0*PI,2.0D0*PI)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the latitude-longitude coordinates, compute a unit vector in
C the EME-coordinate system...
C
C Inputs: ME(3,3) = EME50 conversion matrix
C         RLAT,RLON
C
C Outputs: Q(3) = unit vector in EME50 coordinates
C
      SUBROUTINE TOEME(ME,RLAT,RLON,Q)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 ME(3,3),P(3),Q(3)
C             Compute unit vector in target centered coordinates...
      CALL VECTOR3(1.D0,RLAT,RLON,P)
C             Convert to EME50 coordinates
      Q(1) = ME(1,1)*P(1) + ME(1,2)*P(2) + ME(1,3)*P(3)
      Q(2) = ME(2,1)*P(1) + ME(2,2)*P(2) + ME(2,3)*P(3)
      Q(3) = ME(3,1)*P(1) + ME(3,2)*P(2) + ME(3,3)*P(3)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the latitude-longitude coordinates and range of a point, compute
C its vector in target centered coordinates.
C
C Inputs: RANGE,RLAT,RLON
C Outputs: P(3)
C
      SUBROUTINE VECTOR3(RANGE,RLAT,RLON,P)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 P(3)

      P(1) = RANGE*DCOS(RLAT)*DCOS(RLON)
      P(2) = RANGE*DCOS(RLAT)*DSIN(RLON)
      P(3) = RANGE*DSIN(RLAT)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to compute offsets (DL,DS) which minimize the distance
C between the computed and actual curves:
C             CHISQ2 = SIGMA((DPi - DL*COSLi - DS*COSSi)**2)
C Inputs:  CPTS,APTS,NPTS,IMODE
C     IMODE=1 if goodness of fit measures are to be printed out
C          =0 otherwise
C Outputs: IND,DL,DS
C     IND = 1 if fit was successful
C         = 0 if error (Det=0)
C
      SUBROUTINE CHISQ2(IND,CPTS,APTS,NPTS,DL,DS,IMODE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 CPTS(2,NPTS),APTS(2,NPTS)
C
      DP = 0.D0
      A11 = 0.D0
      A12 = 0.D0
      A22 = 0.D0
      B1 = 0.D0
      B2 = 0.D0
      N = 0			!Count number of points used in fit

      DO 50 I=1,NPTS
      IF (APTS(1,I).LT.0.0) GOTO 50		!Skip point if flagged as bad
      N = N + 1
      DLi = APTS(1,I) - CPTS(1,I)
      DSi = APTS(2,I) - CPTS(2,I)
      DPi = DLi**2 + DSi**2
      IF (DPi.EQ.0.0) GOTO 50
      DP = DP + DPi
      DPi = DSQRT(DPi)
      COSSi = DSi/DPi
      COSLi = DLi/DPi
      A11 = A11 + COSSi**2
      A12 = A12 + COSSi*COSLi
      A22 = A22 + COSLi**2
      B1 = B1 + DSi
      B2 = B2 + DLi
   50 CONTINUE
C
      Det = A11*A22 - A12**2
      IF (DABS(Det).LT.1.D-6) GOTO 990
      DL = (B2*A11 - B1*A12)/Det
      DS = (B1*A22 - B2*A12)/Det
      IND = 1
      IF (IMODE.EQ.0) RETURN
C
C     ....The remainder of the routine measures "goodness of fit"
C     ....Compute CHISQ2 and Covariance
      CALL PRNT(4,1,N,' Number of points used in fit=.')
      IF (N.LE.2) GOTO 992
      CHISQ = DP + DS**2*A11 + DL**2*A22
     &       - 2*DS*B1 - 2*DL*B2 + 2*DS*DL*A12
      CHISQ = CHISQ/DFLOAT(N-2)/0.5  !Using measurement error of 0.5 in L & S
      CALL PRNT(8,1,CHISQ,' CHISQ2=.')
      CALL COVMT2(A11,A12,A22,2.*CHISQ)
      RETURN

  990 CALL XVMESSAGE('***Error fitting curve',' ')
      CALL PRNT(4,1,N,'***Number of points used in fit=.')
      IND = 0
      RETURN

  992 CALL XVMESSAGE(
     & '***Warning: Insufficient number of points used in fit',' ')
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE COVMT2(A11,A12,A22,VAR)  !Fixed by VRH 5/23/89
      IMPLICIT NONE
      REAL*8 A11,A12,A22,VAR
      REAL*8 CA11,CA12,CA22,DETA
      CHARACTER*80 MSG
C
      DETA = A11*A22 - A12**2
      IF (DETA.LE.0.D0) THEN
          CALL XVMESSAGE('***Warning: Covariance matrix is singular',
     &	   ' ')
          RETURN
      ENDIF
C
      CA11 =  A22*VAR/DETA
      CA12 = -A12*VAR/DETA
      CA22 =  A11*VAR/DETA
C
      CALL XVMESSAGE('Covariant Matrix:  S (pixels), L (pixels)',' ')
      WRITE(MSG,110) CA11,CA12
      CALL XVMESSAGE(MSG,' ')
      WRITE(MSG,110) CA12,CA22
      CALL XVMESSAGE(MSG,' ')
  110 FORMAT('   ',2F20.10)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to Compute offsets (DL,DS) and DT which minimize the distance
C between the computed and actual curves:
C             CHISQ3 = SIGMA((DPi - DL*COSLi - DS*COSSi -DT*RXDi)**2)
C Inputs:  CPTS,APTS,NPTS,OAL,OAS,IMODE
C     IMODE=1 if goodness of fit measures are to be printed out
C          =0 otherwise
C Outputs: IND,DL,DS,DT
C     IND = 1 if fit was successful
C         = 0 if error (Det=0)
C
      SUBROUTINE CHISQ3(IND,CPTS,APTS,NPTS,OAL,OAS,DL,DS,DT,IMODE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 CPTS(2,NPTS),APTS(2,NPTS)
      REAL*8 LAi
C
      DP = 0.D0
      A11 = 0.D0
      A22 = 0.D0
      A33 = 0.D0
      A12 = 0.D0
      A13 = 0.D0
      A23 = 0.D0
      B1 = 0.D0
      B2 = 0.D0
      B3 = 0.D0
      N = 0			!Count number of points used in fit
C
      DO 50 I=1,NPTS
      LAi = APTS(1,I)
      IF (LAi.LT.0.0) GOTO 50		!Skip point if flagged as bad
      N = N + 1
      SAi = APTS(2,I)
      DLi = LAi - CPTS(1,I)
      DSi = SAi - CPTS(2,I)
      DPi = DLi**2 + DSi**2
      IF (DPi.LE.0.0) GOTO 50
      DP = DP + DPi
      DPi = DSQRT(DPi)
      COSSi = DSi/DPi
      COSLi = DLi/DPi
      RXDi = (SAi-OAS)*COSLi - (LAi-OAL)*COSSi
      A11 = A11 + COSSi**2
      A22 = A22 + COSLi**2
      A33 = A33 + RXDi**2
      A12 = A12 + COSSi*COSLi
      A13 = A13 + COSSi*RXDi
      A23 = A23 + COSLi*RXDi
      B1 = B1 + DSi
      B2 = B2 + DLi
      B3 = B3 + DPi*RXDi
   50 CONTINUE
C
      D11 = A22*A33 - A23**2
      D22 = A11*A33 - A13**2
      D33 = A11*A22 - A12**2
      D12 = A12*A33 - A13*A23
      D13 = A12*A23 - A13*A22
      D23 = A11*A23 - A13*A12
      Det = A11*D11 - A12*D12 + A13*D13
      IF (DABS(Det).LT.1.D-6) THEN
           CALL PRNT(4,1,N,' Number of points used in fit=.')
           CALL XVMESSAGE('***Error fitting curve',' ')
           IND = 0
           RETURN
      ENDIF
      DS =  (B1*D11 - B2*D12 + B3*D13)/Det
      DL = (-B1*D12 + B2*D22 - B3*D23)/Det
      DT =  (B1*D13 - B2*D23 + B3*D33)/Det
      IND = 1
      IF (IMODE.EQ.0) RETURN
C
C          The rest of the routine measures "goodness of fit"
      CALL PRNT(4,1,N,' Number of points used in fit=.')
      IF (N.LE.3) THEN
           CALL XVMESSAGE(
     &      '***Warning: Insufficient number of points used in fit',
     &	    ' ')
           RETURN
      ENDIF
C          Compute RMS and Covariance
      CHISQ = DP + DS**2*A11 + DL**2*A22 + DT**2*A33
     &           + 2*DS*DL*A12 + 2*DS*DT*A13 + 2*DL*DT*A23
     &           - 2*DS*B1     - 2*DL*B2     - 2*DT*B3
      CHISQ = CHISQ/DFLOAT(N-3)/0.5  !Using measurement error of 0.5 in L & S
      CALL PRNT(8,1,CHISQ,' CHISQ3=.')
      CALL COVMT3(A11,A12,A13,A22,A23,A33,2.*CHISQ)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE COVMT3(A11,A12,A13,A22,A23,A33,VAR)  !Fixed by VRH 5/23/89
      IMPLICIT NONE
      REAL*8 A11,A12,A13,A22,A23,A33,VAR
      REAL*8 CA11,CA12,CA13,CA22,CA23,CA33,DETA
      CHARACTER*80 MSG
C
      DETA = A11*(A22*A33-A23*A23) - A12*(A12*A33-A23*A13)
     *     + A13*(A12*A23-A22*A13)
      IF (DETA.LE.0.D0) THEN
        CALL XVMESSAGE('***Warning: Covariance matrix is singular',
     1   ' ')
        RETURN
      ENDIF
C
      CA11 = (A22*A33 - A23*A23)*VAR/DETA
      CA12 = (A23*A13 - A12*A33)*VAR/DETA
      CA13 = (A12*A23 - A22*A13)*VAR/DETA
      CA22 = (A11*A33 - A13*A13)*VAR/DETA
      CA23 = (A12*A13 - A11*A23)*VAR/DETA
      CA33 = (A11*A22 - A12*A12)*VAR/DETA
C
      CALL XVMESSAGE('Covariant Matrix: S, L (pixels), N (radians)',' ')
      WRITE(MSG,110) CA11,CA12,CA13
      CALL XVMESSAGE(MSG,' ')
      WRITE(MSG,110) CA12,CA22,CA23
      CALL XVMESSAGE(MSG,' ')
      WRITE(MSG,110) CA13,CA23,CA33
      CALL XVMESSAGE(MSG,' ')
  110 FORMAT('   ',3F20.10)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given computed star coordinates CPTS and the actual coordinates APTS,
C determine displacements (DL,DS) which register the two.
C
      SUBROUTINE FIT2(APTS,CPTS,NPTS,DL,DS)
      REAL*4 APTS(2,NPTS),CPTS(2,NPTS)
      REAL*8 DL,DS

      DL = 0.D0
      DS = 0.D0

      DO 50 I=1,NPTS
      DL = DL + APTS(1,I) - CPTS(1,I)
      DS = DS + APTS(2,I) - CPTS(2,I)
   50 CONTINUE

      DL = DL/NPTS
      DS = DS/NPTS
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the computed star coordinates CPTS and their actual line-sample
C coordinates APTS compute the (line,sample) and north angle displacements
C (DL,DS) and DT to register the two sets.
C RETURN1 on error.
C
      SUBROUTINE FIT3(APTS,CPTS,NPTS,OAL,OAS,dl,ds,dt,*)
      IMPLICIT REAL*8 (A-H,O-Z)		! VRH added for OAL,... Real*8 6/8/89
      REAL*4 APTS(2,NPTS),CPTS(2,NPTS)

      A13 = 0.D0
      A23 = 0.D0
      A33 = 0.D0
      B1 = 0.D0
      B2 = 0.D0
      B3 = 0.D0

      DO 50 I=1,NPTS
      DL = APTS(1,I) - CPTS(1,I)
      DS = APTS(2,I) - CPTS(2,I)
      V = OAL - APTS(1,I)
      U = APTS(2,I) - OAS
      A13 = A13 + U
      A23 = A23 + V
      A33 = A33 + U**2 + V**2
      B1 = B1 + DL
      B2 = B2 + DS
      B3 = B3 + U*DL + V*DS
   50 CONTINUE

      N = NPTS
      Det = N*(N*A33-A13**2-A23**2)
      IF (Det.EQ.0.0) THEN
          CALL XVMESSAGE('***Fit3 error.',' ')
          RETURN1
      ENDIF

      DL = (N*(B1*A33-B3*A13) + A23*(B2*A13-B1*A23))/Det
      DS = (N*(B2*A33-B3*A23) + A13*(B1*A23-B2*A13))/Det
      DT = (N*(N*B3-B1*A13-B2*A23))/Det
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given a displacement of the optical axis of (DL,DS) in the image plane,
C compute the resulting changes in ANGLA and ANGLB.
C
C Inputs: DL,DS,ANGLN,ZSCALE (where DL and DS are in object-space)
C Updated: ANGLA,ANGLB
C
      SUBROUTINE MOVE1(DL,DS,ANGLN,ANGLA,ANGLB,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
C
      SCALE = DSQRT(ZSCALE**2+DL**2+DS**2)
      DUX = DS/SCALE
      DUY = DL/SCALE
      DA = DUX*DCOS(ANGLN) + DUY*DSIN(ANGLN)
      DB = (DUX*DSIN(ANGLN) - DUY*DCOS(ANGLN))/DSIN(ANGLA)
      ANGLA = ANGLA + DA
      ANGLB = ANGLB + DB
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given a displacement of the optical axis of (DL,DS) in the image plane,
C computes the resulting changes in ANGLA and ANGLB.  This version uses
C the old farenc algorithm due to Ingersoll, circa 1980.
C
C Inputs: DL,DS,ANGLN
C Updated: ANGLA,ANGLB
C 95-11-1 -lwk- ANGLA,ANGLB,ANGLN,PSC3,SCLAT,SCLON are in common /CMAP/,
c		removed from argument list
C
C Note: CMAP must be in planet coordinate system
C
      SUBROUTINE MOVE2(DL,DS,*)
      IMPLICIT REAL*8 (A-H,O-Z)

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD

      REAL*8 OMp(3,3),RS(3)

C            Get current planet center....
      CALL PLAINV(IND,SCLAT,SCLON,SCLINE,SCSAMP,
     &            OM,PSC3,RLORA,OAL,OAS,ZSCALE)
      IF (IND.EQ.0) THEN
            CALL XVMESSAGE('***Err calculating planet center',' ')
            RETURN1
      ENDIF
C             Update planet center...
      SCLINE = SCLINE + DL
      SCSAMP = SCSAMP + DS
C            Calculate OMp transpose...
      SCLA = SCLAT*RTD
      SCLO = (2.D0*PI-SCLON)*RTD
      ANGN = ANGLN*RTD + 90.D0	!IPL north angle
      CALL MOMATI(OAL,OAS,SCLINE,SCSAMP,PSCALE,FL,SCLO,SCLA,ANGN,
     &       RSC,OMp,RS)
C            Calculate C-matrix...
      DO 20 J=1,3
      DO 20 I=1,3
   20 CM(I,J) = ME(I,1)*OMp(J,1)+ME(I,2)*OMp(J,2)+ME(I,3)*OMp(J,3)
C            Compute angles N, A, and B...
      CALL GETANGLES(CM,ME(1,3),PSC,ANGLN,ANGLA,ANGLB)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Update C-matrix and all OM-matrices
C
      SUBROUTINE UPDATENAV
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD

      real*4 scl4,scs4
      REAL*8 CM0(3,3)
      CHARACTER*80 MSG
  112 FORMAT('Object Space PC (LINE,SAMP)=(',F10.2,',',F10.2,')  ANGLN='
     &,F8.3)
  114 FORMAT(' Image Space PC (LINE,SAMP)=(',F10.2,',',F10.2,')')

      CALL CMATRIX(ME,ANGLN,ANGLA,ANGLB,SCLON,CM0)  !Compute C-matrix
C           Update the pointing for the planet...
      CALL GETNAV
      CALL MVE(7,18,CM0,CM,1,1)
      CALL GETANGLES(CM,ME(1,3),PSC,ANGLN,ANGLA,ANGLB)
      CALL OMMATRIX(ANGLN,ANGLA,ANGLB-SCLON+RLORA,OM) !Compute OM-matrix
      CALL PUTNAV
      CALL PLAINV(ind,SCLAT,SCLON,scline,scsamp,      !Compute planet center
     &		OM,PSC3,RLORA,OAL,OAS,ZSCALE)
      WRITE(MSG,112,ERR=10) SCLINE,SCSAMP,ANGLN*RTD   !Print object-space PC
   10 CALL XVMESSAGE(MSG,' ')
      IF (ITYPE.EQ.7) THEN
         CALL CONVISOS(PROJECT,ICAM,scl4,scs4,SNGL(SCLINE),
     &   SNGL(SCSAMP),0,CONV,NPH,NPV,ind)
         SCLINE=SCL4
         SCSAMP=SCS4
         WRITE(MSG,114,ERR=12) SCLINE,SCSAMP	      !Print image-space PC
   12    CALL XVMESSAGE(MSG,' ')
      ENDIF
C          Now update pointing for all the rings...
      DO IRING=1,NRINGS
          CALL GETRING(IRING)
          CALL GETANGLES(CM0,ME(1,3),PSC,ANGLN,ANGLA,ANGLB)
          CALL OMMATRIX(ANGLN,ANGLA,ANGLB-SCLON+RLORA,OM) !Compute OM-matrix
          CALL PUTRING(IRING)
      ENDDO

      CALL GETNAV	!Restore the planet's reference frame
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Update each of the ring geometries as a result of changes to PSC, RSC,
C PSUN,RSUN,RLORA, or CM.
C
      SUBROUTINE UPDTRING
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      CALL PUTNAV			! First save the planet

      DO IRING=1,NRINGS
          CALL GETRING(IRING)
          CALL FROMEME(ME,PSC,SCLAT,SCLON)	       ! Compute SCLAT,SCLON
          CALL VECTOR3(RSC,SCLAT,SCLON-RLORA,PSC3)     ! Compute PSC3
          CALL FROMEME(ME,PSUN,SUNLAT,SUNLON)	       ! Compute SUNLAT,SUNLON
          CALL VECTOR3(RSUN,SUNLAT,SUNLON-RLORA,PSUN3) ! Compute PSUN3
          CALL GETANGLES(CM,ME(1,3),PSC,ANGLN,ANGLA,ANGLB)
          CALL OMMATRIX(ANGLN,ANGLA,ANGLB-SCLON+RLORA,OM) !Compute OM
          CALL PUTRING(IRING)
      ENDDO

      CALL GETNAV			! Restore the planet
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routines to save and retrieve planet and ring navigation data..
C Navigation data is saved in three buffers: (1) ORIG, (2) LAST, and
C (3) CURR.  ORIG contains the original data retrieved from the SEDR.
C The version of the camera pointing contained in ORIG is controlled
C by the SEDRSRC parameter.  LAST contains
C the last saved version of the data.  CURR contains the current version
C of the data.   Each of these three save areas contain all the navigation
C data for the planet and each of the rings.  The buffer CMAP contains either
C the planet geometry, or one of the ring geometries, and is the buffer
C which all the navigation routines use.
C
C  GETNAV moves the planet geometry from CURR to CMAP (inverse is PUTNAV)
C  GETRING moves a ring geometry from RSAV to CMAP (inverse is PUTRING)
C  GETLAST moves LAST to CURR (inverse is SAVELAST).  GETNAV is then called.
C  GETSEDR moves ORIG to CURR (inverse is SAVESEDR).  GETNAV is then called.
C
      SUBROUTINE GETNAV
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CPIC/IPROJ,ICAM,FRAME_ID,PLANET_ID
      COMMON/CPIC/TARGET_ID,IDATE,ITIME
      COMMON/CPICX/T0,T
      INTEGER*4 IPROJ,ICAM,FRAME_ID,PLANET_ID,TARGET_ID

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/PCONST/AI2,BI2,CI2,AI2XS,BI2YS,CI2ZS,CTERM
      COMMON/PCONST/A0,B0,B1,C0,C1,C2

      COMMON/CURR/CUR(71),PCCUR(13)
      COMMON/LAST/LAS(71),PCLAS(13)
      COMMON/ORIG/ORG(71),PCORG(13)
      COMMON/RSAV/RSAVE(38,15)
      REAL*8 LAS

      IRING = 1
      CALL MVE(8,71,CUR,FL,1,1)		!Get planet geometry
      CALL MVE(8,13,PCCUR,AI2,1,1)
      RETURN
C
      ENTRY PUTNAV
      CALL MVE(8,71,FL,CUR,1,1)		!Put planet geometry
      CALL MVE(8,13,AI2,PCCUR,1,1)
      RETURN

      ENTRY GETRING(JRING)
      CALL MVE(8,38,RSAVE(1,JRING),ME,1,1)	!Get orbital data for ring
      RETURN

      ENTRY PUTRING(JRING)
      CALL MVE(8,38,ME,RSAVE(1,JRING),1,1)	!Put orbital data for ring
      RETURN

      ENTRY GETSEDR
      IRING = 1
      CALL MVE(8,84,ORG,CUR,1,1)	!Get nominal planet geometry
      CALL MVE(8,71,CUR,FL,1,1)		!Get planet geometry, CM etc.
      CALL MVE(8,13,PCCUR,AI2,1,1)
      CALL ERING0(PLANET_ID,T,T0,1)	!Navigate rings 7/27/89 ",1" added
      CALL MVE(8,71,CUR,FL,1,1)		!Restore planet geometry
      CALL MVE(8,13,PCCUR,AI2,1,1)
      RETURN

      ENTRY SAVESEDR
      CALL MVE(8,84,CUR,ORG,1,1)	!Save nominal planet geometry
      RETURN

      ENTRY GETLAST
      IRING = 1
      CALL MVE(8,84,LAS,CUR,1,1)	!Get last planet geometry
      CALL MVE(8,71,CUR,FL,1,1)		!Get planet geometry, CM etc.
      CALL MVE(8,13,PCCUR,AI2,1,1)
      CALL ERING0(PLANET_ID,T,T0,1)	!Navigate rings 7/27/89 ",1" added
      CALL MVE(8,71,CUR,FL,1,1)		!Restore planet geometry
      CALL MVE(8,13,PCCUR,AI2,1,1)
      RETURN

      ENTRY SAVELAST
      CALL MVE(8,84,CUR,LAS,1,1)	!Save last planet geometry
      RETURN
      END


      SUBROUTINE TG01HU( COMPQ, COMPZ, L, N, M1, M2, P, N1, LBE, A, LDA,
     $                   E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR,
     $                   NRBLCK, RTAU, TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Given the descriptor system (A-lambda*E,B,C) with the system
C     matrices A, E and B of the form
C
C            ( A1 X1 )        ( E1 Y1 )        ( B1 B2 )
C        A = (       ) ,  E = (       ) ,  B = (       ) ,
C            ( 0  X2 )        ( 0  Y2 )        ( 0  0  )
C
C     where
C          - B is an L-by-(M1+M2) matrix,
C            with B1 an N1-by-M1 submatrix, B2 an N1-by-M2 submatrix,
C          - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix,
C          - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix
C              with LBE nonzero sub-diagonals,
C     this routine reduces the pair (A1-lambda*E1,[B1 B2]) to the form
C
C     Qc'*[B1 B2 A1-lambda*E1 ]*diag(I,Zc) =
C
C                              ( Bc1 Bc2 Ac-lambda*Ec      *         )
C                              (                                     ) ,
C                              (  0   0       0       Anc-lambda*Enc )
C
C     where:
C     1) the pencil ( Bc1 Bc2 Ac-lambda*Ec ) has full row rank NR for
C        all finite lambda and is in a staircase form with
C
C                [ A11 A12  . . .  A1,p-2 A1,p-1 A1p ]
C                [ A21 A22  . . .  A2,p-2 A2,p-1 A2p ]
C                [ A31 A32  . . .  A3,p-2 A3,p-1 A3p ]
C                [  0  A42  . . .  A4,p-2 A4,p-1 A4p ]
C           Ac = [  .   .   . . .    .      .     .  ],              (1)
C                [  .   .     . .    .      .     .  ]
C                [  .   .       .    .      .     .  ]
C                [  0   0   . . .  Ap,p-2 Ap,p-1 App ]
C
C
C                     [ A1,-1 A1,0 ]
C                     [  0    A2,0 ]
C                     [  0     0   ]             ( E11  E12 ...  E1p  )
C                     [  0     0   ]             (  0   E22 ...  E2p  )
C         [Bc1 Bc2] = [  .     .   ],       Ec = (   .   .   .    .   ),
C                     [  .     .   ]             (   .   .   .    .   )
C                     [  .     .   ]             (   0   0  ...  Epp  )
C                     [  0     0   ]
C
C         where the block  Ai,i-2 is an rtau(i)-by-rtau(i-2) full row
C         rank matrix (with rtau(-1) = M1, rtau(0) = M2) and Ei,i is an
C         rtau(i)-by-rtau(i) upper triangular matrix.
C
C      2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc
C         upper triangular; this pencil contains the uncontrollable
C         finite eigenvalues of the pencil (A1-lambda*E1).
C
C     The transformations are applied to the whole matrices A, E, B
C     and C. The left and/or right orthogonal transformations Qc and Zc,
C     performed to reduce the pencil, can be optionally accumulated in
C     the matrices Q and Z, respectively.
C
C     The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no
C     uncontrollable finite eigenvalues and has the same transfer-
C     function matrix as the original system (A-lambda*E,B,C).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of descriptor state equations; also the number
C             of rows of the matrices A, E and B.  L >= 0.
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             number of columns of the matrices A, E and C.  N >= 0.
C
C     M1      (input) INTEGER
C             The number of system inputs in U1, or of columns of B1.
C             M1 >= 0.
C
C     M2      (input) INTEGER
C             The number of system inputs in U2, or of columns of B2.
C             M2 >= 0.
C
C     P       (input) INTEGER
C             The dimension of descriptor system output; also the
C             number of rows of the matrix C.  P >= 0.
C
C     N1      (input) INTEGER
C             The order of the subsystem (A1-lambda*E1,B1,C1) to be
C             reduced.  MIN(L,N) >= N1 >= 0.
C
C     LBE     (input) INTEGER
C             The number of nonzero sub-diagonals of the submatrix E1.
C             MAX(0,N1-1) >= LBE >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the L-by-N state matrix A in the partitioned form
C
C                      ( A1 X1 )
C                  A = (       ) ,
C                      ( 0  X2 )
C
C             where A1 is N1-by-N1.
C             On exit, the leading L-by-N part of this array contains
C             the transformed state matrix,
C
C                                          ( Ac  *   * )
C                       Qc'*A*diag(Zc,I) = ( 0  Anc  * ) ,
C                                          ( 0   0   * )
C
C             where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR).
C             The matrix ( Bc Ac ) is in the controllability staircase
C             form (1).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the L-by-N descriptor matrix E in the partitioned
C             form
C                      ( E1 Y1 )
C                  E = (       ) ,
C                      ( 0  Y2 )
C
C             where E1 is an N1-by-N1 matrix with LBE nonzero
C             sub-diagonals.
C             On exit, the leading L-by-N part of this array contains
C             the transformed descriptor matrix
C
C                                          ( Ec  *   * )
C                       Qc'*E*diag(Zc,I) = ( 0  Enc  * ) ,
C                                          ( 0   0   * )
C
C             where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR).
C             Both Ec and Enc are upper triangular and Enc is
C             nonsingular.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             with M = M1 + M2.
C             On entry, the leading L-by-M part of this array must
C             contain the L-by-M input matrix B in the partitioned form
C
C                      ( Bi )
C                  B = (    ) ,
C                      ( 0  )
C
C             where Bi is N1-by-M.
C             On exit, the leading L-by-M part of this array contains
C             the transformed input matrix
C
C                               ( Bc )
C                       Qc'*B = (    ) ,
C                               ( 0  )
C
C             where Bc is NR-by-M.
C             The matrix ( Bc Ac ) is in the controllability staircase
C             form (1).
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,L).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Zc.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,L)
C             If COMPQ = 'N': Q is not referenced.
C             If COMPQ = 'I': on entry, Q need not be set;
C                             on exit, the leading L-by-L part of this
C                             array contains the orthogonal matrix Qc,
C                             where Qc' is the product of the
C                             transformations applied to A, E, and B on
C                             the left.
C             If COMPQ = 'U': on entry, the leading L-by-L part of this
C                             array must contain an orthogonal matrix Q;
C                             on exit, the leading L-by-L part of this
C                             array contains the orthogonal matrix
C                             Q*Qc.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,L), if COMPQ = 'I' or 'U'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N': Z is not referenced.
C             If COMPZ = 'I': on entry, Z need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Zc,
C                             i.e., the product of the transformations
C                             applied to A, E, and C on the right.
C             If COMPZ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix Z;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Z*Zc.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'I' or 'U'.
C
C     NR      (output) INTEGER
C             The order of the reduced matrices Ac and Ec, and the
C             number of rows of the reduced matrix Bc; also the order of
C             the controllable part of the pair (B, A-lambda*E).
C
C     NRBLCK  (output) INTEGER
C             The number p, of full row rank blocks Ai,i-2 in the
C             staircase form of the pencil (Bc1 Bc2 Ac-lambda*Ec).
C
C     RTAU    (output) INTEGER array, dimension (2*N1)
C             The leading NRBLCK elements of this array contain the
C             orders of the diagonal blocks of Ac. NRBLCK is always
C             an even number, and the NRBLCK/2 odd and even components
C             of RTAU have decreasing values, respectively.
C             Note that some elements of RTAU can be zero.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A-lambda*E, B). If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = L*N*EPS,  is used instead, where
C             EPS is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1, if MIN(N1,M) = 0; otherwise,
C             LDWORK >= MAX(N1+MAX(L,N,M),2*M), if LBE > 0 and N1 > 2;
C             LDWORK >= MAX(1,L,N,2*M),         if LBE = 0 or N1 <= 2.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The implemented algorithm [1] represents a specialization of the
C     controllability staircase algorithm of [2] to the special structure
C     of the input matrix B = [B1,B2].
C
C     REFERENCES
C
C     [1] Varga, A.
C         Reliable algorithms for computing minimal dynamic covers for
C         descriptor systems.
C         Proc. of MTNS'04, Leuven, Belgium, 2004.
C
C     [2] Varga, A.
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N*N1**2 )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     April 2003. Based on the SLICOT routine TG01HX.
C
C     REVISIONS
C
C     A. Varga, Dec. 2006.
C     V. Sima, Dec. 2016, Mar. 2019.
C
C     KEYWORDS
C
C     Controllability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ
      INTEGER            INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDWORK,
     $                   LDZ, M1, M2, N, N1, NR, NRBLCK, P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * ), RTAU( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            B1RED, ILQ, ILZ, LQUERY, ONECOL, WITHC
      INTEGER            I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX,
     $                   ISMIN, J, JB2, K, M, MCRT, MCRT1, MCRT2,
     $                   MINWRK, MN, NB, NF, NR1, NX, RANK, WRKOPT
      DOUBLE PRECISION   C1, C2, CO, RCOND, S1, S2, SI, SMAX, SMAXPR,
     $                   SMIN, SMINPR, SVLMAX, SVMA, SVMR, T, TOLZ, TT
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE, DLAPY2, DNRM2
      EXTERNAL           DLAMCH, DLANGE, DLAPY2, DNRM2, IDAMAX, ILAENV,
     $                   LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEQRF, DLACPY, DLAIC1, DLARF, DLARFG,
     $                   DLARTG, DLASET, DORMQR, DROT, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN, SQRT
C
C     .. Executable Statements ..
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input scalar parameters.
C
      INFO = 0
      IF( ICOMPQ.LE.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -2
      ELSE IF( L.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M1.LT.0 ) THEN
         INFO = -5
      ELSE IF( M2.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN
         INFO = -8
      ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN
         INFO = -9
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -11
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -13
      ELSE IF( LDB.LT.MAX( 1, L ) ) THEN
         INFO = -15
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -17
      ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN
         INFO = -19
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -21
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -25
      ELSE
         M = M1 + M2
         IF( MIN( N1, M ).EQ.0 ) THEN
            MINWRK = 1
         ELSE IF( LBE.GT.0 .AND. N1.GT.2 ) THEN
            MINWRK = MAX( N1 + MAX( L, N, M ), 2*M )
         ELSE
            MINWRK = MAX( 1, L, N, 2*M )
         END IF
C
         LQUERY = LDWORK.EQ.-1
         IF( LQUERY ) THEN
            IF( LBE.GT.0 .AND. N1.GT.2 ) THEN
               CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, N1 + INT( DWORK(1) ) )
               CALL DORMQR( 'Left', 'Transpose', N1, N, N1, E, LDE,
     $                      DWORK, A, LDA, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(1) ) )
               CALL DORMQR( 'Left', 'Transpose', N1, M, N1, E, LDE,
     $                      DWORK, B, LDB, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(1) ) )
               IF( ILQ ) THEN
                  CALL DORMQR( 'Right', 'NoTranspose', L, N1, N1, E,
     $                         LDE, DWORK, Q, LDQ, DWORK, -1, INFO )
                  WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(1) ) )
               END IF
            ELSE
               WRKOPT = MINWRK
            END IF
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -28
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01HU', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Initialize Q and Z if necessary.
C
      IF( ICOMPQ.EQ.3 )
     $   CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Initialize output variables.
C
      NR = 0
      NRBLCK = 0
C
C     Quick return if possible.
C
      IF( MIN( N1, M ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      TOLZ   = DLAMCH( 'Precision' )
      WITHC  = P.GT.0
      SVLMAX = DLANGE( 'F', L, M, B, LDB, DWORK )
      RCOND  = TOL
      IF ( RCOND.LE.ZERO ) THEN
C
C        Use the default tolerance in controllability determination.
C
         RCOND = DBLE( L*N )*TOLZ
      END IF
      TOLZ = SQRT( TOLZ )
C
      IF ( SVLMAX.LT.RCOND )
     $   SVLMAX = ONE
      SVMR = SVLMAX*RCOND
      SVMA = MAX( ONE, DLANGE( 'F', L, N, A, LDA, DWORK ) )*RCOND
      IF( SVMA.GT.SVMR*TOLZ )
     $    SVMA = DLAPY2( SVMR, SVMA )
      NX = ILAENV( 3, 'DGEQRF', ' ', N1, N1, -1, -1 )
      NB = LDWORK/N1
C
C     Reduce E to upper triangular form if necessary.
C
      IF( LBE.GT.NX/2 .AND. MIN( NB, N1 ).GE.NX ) THEN
C
C        If E1 is a rather full matrix of enough size, use its
C        QR decomposition and apply it to A, B, and Q (if needed).
C        Workspace:  need    2*N1;
C                    prefer  N1 + N1*NB.
C
         CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK(N1+1), LDWORK-N1,
     $                INFO )
         WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) )
C
C        Workspace:  need    N1 + N;
C                    prefer  N1 + N*NB.
C
         CALL DORMQR( 'Left', 'Transpose', N1, N, N1, E, LDE, DWORK, A,
     $                LDA, DWORK(N1+1), LDWORK-N1, INFO )
         WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) )
C
C        Workspace:  need    N1 + M;
C                    prefer  N1 + M*NB.
C
         CALL DORMQR( 'Left', 'Transpose', N1, M, N1, E, LDE, DWORK, B,
     $                LDB, DWORK(N1+1), LDWORK-N1, INFO )
         WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) )
         IF( ILQ ) THEN
C
C           Workspace:  need    N1 + L;
C                       prefer  N1 + L*NB.
C
            CALL DORMQR( 'Right', 'NoTranspose', L, N1, N1, E, LDE,
     $                   DWORK, Q, LDQ, DWORK(N1+1), LDWORK-N1, INFO )
            WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) )
         END IF
         CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE )
      ELSE IF( LBE.GT.0 .AND. N1.GT.1 ) THEN
         DO 10 I = 1, N1 - 1
C
C           Generate elementary reflector H(i) to annihilate
C           E(i+1:i+lbe,i).
C
            K = MIN( LBE, N1-I ) + 1
            CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT )
            T = E(I,I)
            E(I,I) = ONE
C
C           Apply H(i) to E(i:n1,i+1:n) from the left.
C
            CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT,
     $                  E(I,I+1), LDE, DWORK )
C
C           Apply H(i) to A(i:n1,1:n) from the left.
C
            CALL DLARF( 'Left', K, N, E(I,I), 1, TT,
     $                  A(I,1), LDA, DWORK )
C
C           Apply H(i) to B(i:n1,1:m) from the left.
C
            CALL DLARF( 'Left', K, M, E(I,I), 1, TT,
     $                  B(I,1), LDB, DWORK )
            IF( ILQ ) THEN
C
C              Apply H(i) to Q(1:l,i:n1) from the right.
C
               CALL DLARF( 'Right', L, K, E(I,I), 1, TT,
     $                     Q(1,I), LDQ, DWORK )
            END IF
            E(I,I) = T
   10    CONTINUE
         CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE )
      END IF
C
      MCRT1 = M1
      MCRT2 = M2
      MCRT  = MCRT1
      B1RED = .TRUE.
      ISMIN = 1
      ISMAX = ISMIN + M
C
      IC  = 0
      NF  = N1
      JB2 = M
C
   20 CONTINUE
      IF( NF.EQ.0 .AND. B1RED )
     $   GO TO 120
      NRBLCK = NRBLCK + 1
      RANK   = 0
C
      IF( NF.GT.0 ) THEN
C
C        IROW will point to the current pivot line in B,
C        ICOL+1 will point to the first active columns of A.
C
         ICOL = IC
         IROW = NR
         NR1  = NR + 1
         IF( NRBLCK.EQ.2 ) THEN
            CALL DLACPY( 'Full', NF, M2, B(NR1,M1+1), LDB,
     $                   B(NR1,1), LDB )
            JB2 = MCRT
         ELSEIF( NRBLCK.GT.2 ) THEN
            CALL DLACPY( 'Full', NF, MCRT, A(NR1,IC+1), LDA,
     $                   B(NR1,1), LDB )
            ICOL = IC + MCRT
            SVMR = SVMA
            JB2  = MCRT
         ENDIF
         ONECOL = MCRT.EQ.1
C
C        Perform QR-decomposition with column pivoting on the current B
C        while keeping E upper triangular.
C        The current B is at first iteration B1, at second iteration B2
C        and for subsequent iterations the NF-by-MCRT matrix delimited
C        by rows NR + 1 to N1 and columns IC + 1 to IC + MCRT of A.
C        The rank of current B is computed in RANK.
C
         IF( ONECOL ) THEN
            MN = 1
         ELSE
            MN = MIN( NF, MCRT )
C
C           Compute column norms.
C
            DO 30 J = 1, MCRT
               DWORK(J)   = DNRM2( NF, B(NR1,J), 1 )
               DWORK(M+J) = DWORK(J)
               IWORK(J)   = J
   30       CONTINUE
         END IF
C
   40    CONTINUE
         IF( RANK.LT.MN ) THEN
            J    = RANK + 1
            IROW = IROW + 1
C
C           Pivot if necessary.
C
            IF( J.NE.MCRT ) THEN
               K = ( J - 1 ) + IDAMAX( MCRT-J+1, DWORK(J), 1 )
               IF( K.NE.J ) THEN
                  CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 )
                  I = IWORK(K)
                  IWORK(K)   = IWORK(J)
                  IWORK(J)   = I
                  DWORK(K)   = DWORK(J)
                  DWORK(M+K) = DWORK(M+J)
               END IF
            END IF
C
C           Zero elements below the current diagonal element of B.
C
            DO 50 I = N1-1, IROW, -1
C
C              Rotate rows I and I+1 to zero B(I+1,J).
C
               T = B(I,J)
               CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) )
               B(I+1,J) = ZERO
               CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI )
               IF( J.LT.JB2 )
     $             CALL DROT( JB2-J, B(I,J+1), LDB, B(I+1,J+1), LDB, CO,
     $                        SI )
               CALL DROT( N-ICOL, A(I,ICOL+1), LDA, A(I+1,ICOL+1), LDA,
     $                    CO, SI )
               IF( ILQ )
     $            CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI )
C
C              Rotate columns I, I+1 to zero E(I+1,I).
C
               T = E(I+1,I+1)
               CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) )
               E(I+1,I) = ZERO
               CALL DROT( I,  E(1,I+1), 1, E(1,I), 1, CO, SI )
               CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI )
               IF( ILZ )
     $            CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI )
               IF( WITHC )
     $            CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI )
   50       CONTINUE
C
            IF( RANK.EQ.0 ) THEN
C
C              Initialize; exit if matrix is zero (RANK = 0).
C              Short pass if the current B has one column.
C
               SMAX = ABS( B(NR1,1) )
               IF ( SMAX.LE.SVMR ) THEN
                  GO TO 80
                ELSE IF ( ONECOL ) THEN
                  RANK = RANK + 1
                  GO TO 80
               END IF
               SMIN   = SMAX
               SMAXPR = SMAX
               SMINPR = SMIN
               C1 = ONE
               C2 = ONE
            ELSE
C
C              One step of incremental condition estimation.
C
               CALL DLAIC1( IMIN, RANK, DWORK(ISMIN), SMIN, B(NR1,J),
     $                      B(IROW,J), SMINPR, S1, C1 )
               CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, B(NR1,J),
     $                      B(IROW,J), SMAXPR, S2, C2 )
            END IF
C
C           Check the rank; finish the loop if rank loss occurs.
C
            IF( SVMR.LE.SMAXPR ) THEN
               IF( SMAXPR*RCOND.LT.SMINPR ) THEN
C
C                 Finish the loop if last row.
C
                  IF( IROW.EQ.N1 ) THEN
                     RANK = RANK + 1
                     GO TO 80
                  END IF
C
C                 Update partial column norms.
C
                  DO 60 I = J + 1, MCRT
                     IF( DWORK(I).NE.ZERO ) THEN
                        T = ABS( B(IROW,I) )/DWORK(I)
                        T = MAX( ( ONE + T )*( ONE - T ), ZERO)
                        TT = T*( DWORK(I)/DWORK(M+I) )**2
                        IF( TT.GT.TOLZ ) THEN
                           DWORK(I) = DWORK(I)*SQRT( T )
                        ELSE
                           DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 )
                           DWORK(M+I) = DWORK(I)
                        END IF
                     END IF
   60             CONTINUE
C
                  DO 70 I = 1, RANK
                     DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1)
                     DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1)
   70             CONTINUE
C
                  DWORK(ISMIN+RANK) = C1
                  DWORK(ISMAX+RANK) = C2
                  SMIN = SMINPR
                  SMAX = SMAXPR
                  RANK = RANK + 1
                  GO TO 40
               END IF
            END IF
         END IF
      END IF
C
   80 CONTINUE
C
      IF( RANK.GT.0 ) THEN
         RTAU(NRBLCK) = RANK
C
C        Back permute interchanged columns.
C
         IF( .NOT.ONECOL ) THEN
            DO 100 J = 1, MCRT
               IF( IWORK(J).GT.0 ) THEN
                  K = IWORK(J)
                  IWORK(J) = -K
   90             CONTINUE
                  IF( K.NE.J ) THEN
                     CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 )
                     IWORK(K) = -IWORK(K)
                     K = -IWORK(K)
                     GO TO 90
                  END IF
               END IF
  100       CONTINUE
         END IF
      END IF
      IF( NRBLCK.EQ.2 ) THEN
         DO 110 J = M2, 1, -1
            CALL DCOPY( NF, B(NR1,J), 1, B(NR1,M1+J), 1 )
  110    CONTINUE
      ELSEIF( NRBLCK.GT.2 ) THEN
         CALL DLACPY( 'Full', NF, MCRT, B(NR1,1), LDB, A(NR1,IC+1),
     $                LDA )
      END IF
      IF( RANK.GT.0 ) THEN
         NR = NR + RANK
         NF = NF - RANK
         IF( NRBLCK.GT.2 )
     $      IC = IC + MCRT
         IF( B1RED ) THEN
            MCRT1 = RANK
            MCRT  = MCRT2
         ELSE
            MCRT2 = RANK
            MCRT  = MCRT1
         END IF
         B1RED = .NOT.B1RED
         GO TO 20
      ELSE
         IF( B1RED ) THEN
            IF( MCRT2.GT.0 ) THEN
               B1RED = .NOT.B1RED
               RTAU(NRBLCK) = 0
               IF( NRBLCK.GT.2 )
     $            IC = IC + MCRT
               MCRT1 = 0
               MCRT  = MCRT2
               GO TO 20
            END IF
            NRBLCK = NRBLCK - 1
         ELSE
            IF( MCRT1.GT.0 ) THEN
               B1RED = .NOT.B1RED
               RTAU(NRBLCK) = 0
               IF( NRBLCK.GT.2 )
     $            IC = IC + MCRT
               MCRT2 = 0
               MCRT  = MCRT1
               GO TO 20
            END IF
            NRBLCK = NRBLCK - 2
         END IF
      END IF
C
  120 CONTINUE
C
      IF( NRBLCK.GT.0 ) THEN
C
         RANK = RTAU(1)
         IF( RANK.LT.N1 )
     $      CALL DLASET( 'Full', N1-RANK, M1, ZERO, ZERO, B(RANK+1,1),
     $                   LDB )
         RANK = RANK + RTAU(2)
         IF( RANK.LT.N1 )
     $      CALL DLASET( 'Full', N1-RANK, M2, ZERO, ZERO,
     $                   B(RANK+1,M1+1), LDB )
      END IF
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of TG01HU ***
      END


      double complex function higgsprop(s)
c--- computes Higgs propagator for Higgs boson four-momentum squared s
c--- if CPscheme = .true. then it is computed in the complex pole
c---   scheme (Goria, Passarino, Rosco, arXiv:1112.5517,
c---           and c.f. Eq. (2.11) of arXiv:1206.4803)
c--- otherwise it takes the usual Breit-Wigner form
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'cpscheme.f'
      !include 'first.f'
      double precision s,mhbarsq,mhbar,gammahbar
      double complex cfac
      save mhbarsq,cfac

      if (CPscheme) then
c--- complex pole scheme propagator
        mhbarsq=hmass**2+hwidth**2
        mhbar=sqrt(mhbarsq)
        gammahbar=mhbar/hmass*hwidth
        cfac=dcmplx(1d0,gammahbar/mhbar)
        higgsprop=cfac/(s*cfac-dcmplx(mhbarsq,0d0))
      else
c--- Breit Wigner propagator
        higgsprop=1d0/dcmplx(s-hmass**2,hmass*hwidth)
      endif

      return

   99 format(' *    MHB = ',f9.4,' GeV    GHB = ',f9.4,' GeV    *')

      end

      double complex function higgs2prop(s)
c--- computes HM Higgs propagator for Higgs boson four-momentum squared s
c--- if CPscheme = .true. then it is computed in the complex pole
c---   scheme (Goria, Passarino, Rosco, arXiv:1112.5517,
c---           and c.f. Eq. (2.11) of arXiv:1206.4803)
c--- otherwise it takes the usual Breit-Wigner form
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'cpscheme.f'
      !include 'first.f'
      include 'spinzerohiggs_anomcoupl.f'
      double precision s,mhbarsq,mhbar,gammahbar
      double complex cfac
      save mhbarsq,cfac

      if(h2mass.lt.zip) then
         higgs2prop=czip
         return
      endif

      if (CPscheme) then
c--- complex pole scheme propagator
        mhbarsq=h2mass**2+h2width**2
        mhbar=sqrt(mhbarsq)
        gammahbar=mhbar/h2mass*h2width
        cfac=dcmplx(1d0,gammahbar/mhbar)
        higgs2prop=cfac/(s*cfac-dcmplx(mhbarsq,0d0))
      else
c--- Breit Wigner propagator
        higgs2prop=1d0/dcmplx(s-h2mass**2,h2mass*h2width)
      endif

      return

   99 format(' *    MHB = ',f9.4,' GeV    GHB = ',f9.4,' GeV    *')

      end


MODULE FUN_xyCROSS
!!#### PURPOSE
!! Cross product for R^2 Cartesian geometry,
!
!!         V_c = xyCROSS_VV( V_a , V_b )
!
!! where V_a, V_b, and V_c are vectors.

!!#### DETAILS
!! The cross product is only defined for two vectors V_a,V_b of the same
!! type-kinds.

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

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyCROSS_VV
 MODULE PROCEDURE xyCROSS_VV_Rsp
 MODULE PROCEDURE xyCROSS_VV_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyCROSS_VV

CONTAINS

PURE FUNCTION xyCROSS_VV_Rsp( V_a , V_b ) RESULT(V_c)
!!#### LOCAL PARAMETERS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyCROSS_VV.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyCROSS_VV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyCROSS_VV_Rdp( V_a , V_b ) RESULT(V_c)
!!#### LOCAL PARAMETERS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyCROSS_VV.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyCROSS_VV.f90.bdy"
!!--end--
END FUNCTION

END MODULE


! /* This code simulates a 2-dimensional laplace equation
!  * using jacobi interation
!  * accelated by mpi
!  * author: btli(2021)
!  */

! /*  data mesh arrangement
!  *  ny
!  *  ^
!  *  | (1,3)
!  *  | (1,2)
!  *  | (1,1)  (2,1)  (3,1)
!  *  ---------------------> nx
!  *
!     for fortran language, data fill row first, (1,1),(2,1) ...
! */

program main
    use mpi
    implicit none

    integer, parameter :: total_nx = 2000, total_ny = 2000, itc_max = 1000
    real(8), parameter :: tolerance = 1.0e-5
    integer :: nx, ny
    integer :: i, j, itc
    real(8),allocatable   :: A(:, :), A_new(:, :), f(:, :), A_p(:, :)
    real(8) :: error, error_max, check_diff
    real(8) :: start_time, end_time
    integer :: rc, rank, num_process, name_len
    character(len=MPI_MAX_PROCESSOR_NAME) :: processor_name
    integer :: dims(2) = (0, 0), coords(2)
    logical :: periods(2)
    data periods/2*.false./
    integer :: comm2d, rank2d, column_y
    integer :: nbr_left, nbr_right, nbr_top, nbr_bottom

    ! type(mpi_status) :: status

    call mpi_init(rc)

    call MPI_Comm_size(MPI_COMM_WORLD, num_process, rc)
    call MPI_Comm_rank(MPI_COMM_WORLD, rank, rc)
    call MPI_Get_processor_name(processor_name, name_len, rc)

    !!! ---- Decomposition the domain
    ! dims(1) = 9
    ! dims(2) = 1
    call MPI_Dims_create(num_process, 2, dims, rc)
    call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, periods, .true., comm2d, rc)
    if(rank == 0) then
        write(*,*) "dimens is x*y = ", dims(1), "x", dims(2)
    endif

    ! get rank in decomposition
    call MPI_Comm_rank(comm2d, rank2d, rc)
    ! write(*,*) "process ", rank, " of total ", num_process, "is alive."

    ! get the neighbors
    call MPI_Cart_shift(comm2d, 0, 1, nbr_left, nbr_right, rc)
    call MPI_Cart_shift(comm2d, 1, 1, nbr_bottom, nbr_top, rc)
    ! write(*,*) "I'm process ", rank, "My neighbor lrbt is", nbr_left, nbr_right, nbr_bottom, nbr_top

    ! determain sub-domain size
    call MPI_Cart_get(comm2d, 2, dims, periods, coords, rc)
    call decompose_1d(total_nx, nx, coords(1), dims(1))
    call decompose_1d(total_ny, ny, coords(2), dims(2))
    ! if(rank == 0) then
    !     write(*,*) "dims = ", dims(1), dims(2)
    ! endif
    ! write(*,*) "coords = ", coords(1), coords(2)
    ! write(*,*) "nx*ny = ", nx, ny

    ! allocate a ghost layer at each boundary
    allocate(A(0:nx+1, 0:ny+1))
    allocate(A_new(0:nx+1, 0:ny+1))
    allocate(f(0:nx+1, 0:ny+1))
    allocate(A_p(0:nx+1, 0:ny+1))

    ! construct the datatype for the exchange in y direction(non-contiguous)
    call MPI_Type_vector(ny+2, 1, nx+2, MPI_DOUBLE_PRECISION, column_y, rc)     ! two ghost layers
    call MPI_Type_commit(column_y, rc)

    call init(A, A_new, f, nx, ny, dims, coords)

    call MPI_Barrier(MPI_COMM_WORLD, rc)
    start_time = MPI_Wtime()

    !! jacobi iteration
    itc = 0
    error_max = 1.0
    A_p = A
    do while(error_max > tolerance .AND. itc <= itc_max)
        itc =  itc + 2
        call jacobi_with_message_exchange(A, A_new, f, nx, ny, coords, comm2d, column_y, &
                                nbr_left, nbr_right, nbr_bottom, nbr_top)

        call jacobi_with_message_exchange(A_new, A, f, nx, ny, coords, comm2d, column_y, &
                                nbr_left, nbr_right, nbr_bottom, nbr_top)

        if(MOD(itc, 100) == 0) then
            error = check_diff(A, A_p, nx, ny)
            call MPI_Allreduce(error, error_max, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm2d, rc)
            if(rank == 0) then
                write(*, *) itc, error_max
            endif
        endif
    enddo

    call MPI_Barrier(MPI_COMM_WORLD, rc);
    end_time = MPI_Wtime()
    if (rank == 0) then
        write(*,*) "Total run time =", end_time-start_time, "s."
    endif

    deallocate(A)
    deallocate(A_new)
    deallocate(A_p)
    deallocate(f)

    call MPI_Finalize(rc)

end program main

subroutine decompose_1d(total_n, local_n, rank, num_process)
    implicit none
    integer, intent(in) :: total_n, rank, num_process
    integer, intent(out) :: local_n

    local_n = total_n / num_process

    if (rank < MOD(total_n, num_process)) then
        local_n = local_n + 1
    endif

end subroutine decompose_1d

subroutine init(A, A_new, f, nx, ny, dims, coords)
    implicit none
    integer, intent(in) :: nx, ny, dims(2), coords(2)
    real(8), intent(inout) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1), f(0:nx+1, 0:ny+1)
    integer :: i, j

    ! initialize
    do j = 0, ny+1
        do i = 0, nx+1
            A(i, j) = 0.0d0
            A_new(i, j) = 0.0d0
            f(i, j) = 0.0d0
        enddo
    enddo

    ! boundary condition (top boundary = 1.0, others = 0.0)
    if (coords(2) == dims(2) - 1) then
        do i = 0, nx+1
            A(i, ny+1) = 1.0d0
            A_new(i, ny+1) = 1.0d0
        enddo
    endif

end subroutine init

subroutine jacobi_with_message_exchange(A, A_new, f, nx, ny, coord, comm2d, column_y, nbr_left, nbr_right, nbr_bottom, nbr_top)
    use mpi
    implicit none
    integer, intent(in) :: nx, ny, comm2d, column_y, coord(2)
    integer, intent(in) :: nbr_left, nbr_right, nbr_top, nbr_bottom
    real(8), intent(inout) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1), f(0:nx+1, 0:ny+1)
    integer :: i, j, rc, req(8)

    ! start message change at boundary
    ! corners don't matter in this problem

    ! exchange messages along y (ghost row)
    ! message passing to top(j++)
    call MPI_Irecv(A(1, 0), nx, MPI_DOUBLE_PRECISION, nbr_bottom, 1, comm2d, req(1), rc)
    call MPI_Isend(A(1, ny), nx, MPI_DOUBLE_PRECISION, nbr_top, 1, comm2d, req(2), rc)

    ! message passing to bottom(j--)
    call MPI_Irecv(A(1, ny+1), nx, MPI_DOUBLE_PRECISION, nbr_top, 0, comm2d, req(3), rc)
    call MPI_Isend(A(1, 1), nx, MPI_DOUBLE_PRECISION, nbr_bottom, 0, comm2d, req(4), rc)

    ! exchange messages along x (ghost column)
    ! message passing to right(i++)
    call MPI_Irecv(A(0, 1), 1, column_y, nbr_left, 0, comm2d, req(5), rc)
    call MPI_Isend(A(nx, 1), 1, column_y, nbr_right, 0, comm2d, req(6), rc)

    ! message passing to left(i--)
    call MPI_Irecv(A(nx+1, 1), 1, column_y, nbr_right, 1, comm2d, req(7), rc)
    call MPI_Isend(A(1, 1), 1, column_y, nbr_left, 1, comm2d, req(8), rc)

    ! update inner points
    do j = 2, ny-1
        do i = 2, nx-1
            A_new(i, j) = 0.25 * (A(i-1, j) + A(i+1, j) + A(i, j-1) + A(i, j+1) + f(i, j))
        enddo
    enddo

    ! wait for message exchange finish
    call MPI_Waitall(8, req, MPI_STATUSES_IGNORE, rc)

    ! update the boundary
    do j = 1, ny, ny-1
        do i = 1, nx
            A_new(i, j) = 0.25 * (A(i-1, j) + A(i+1, j) + A(i, j-1) + A(i, j+1) + f(i, j))
        enddo
    enddo
    do i = 1, nx, nx-1
        do j = 1, ny
            A_new(i, j) = 0.25 * (A(i-1, j) + A(i+1, j) + A(i, j-1) + A(i, j+1) + f(i, j))
        enddo
    enddo

end subroutine jacobi_with_message_exchange

subroutine exchange_message_nonblock(A, nx, ny, coord, comm2d, column_y, nbr_left, nbr_right, nbr_bottom, nbr_top)
    use mpi
    implicit none
    integer, intent(in) :: nx, ny, comm2d, column_y, coord(2)
    integer, intent(in) :: nbr_left, nbr_right, nbr_top, nbr_bottom
    real(8), intent(in) :: A(0:nx+1, 0:ny+1)
    integer :: i, j, rc, req(8)

    ! corners don't matter in this problem

    ! exchange messages along y (ghost row)
    ! message passing to top(j++)
    call MPI_Irecv(A(1, 0), nx, MPI_DOUBLE_PRECISION, nbr_bottom, 1, comm2d, req(1), rc)
    call MPI_Isend(A(1, ny), nx, MPI_DOUBLE_PRECISION, nbr_top, 1, comm2d, req(2), rc)

    ! message passing to bottom(j--)
    call MPI_Irecv(A(1, ny+1), nx, MPI_DOUBLE_PRECISION, nbr_top, 0, comm2d, req(3), rc)
    call MPI_Isend(A(1, 1), nx, MPI_DOUBLE_PRECISION, nbr_bottom, 0, comm2d, req(4), rc)

    ! exchange messages along x (ghost column)
    ! message passing to right(i++)
    call MPI_Irecv(A(0, 1), 1, column_y, nbr_left, 0, comm2d, req(5), rc)
    call MPI_Isend(A(nx, 1), 1, column_y, nbr_right, 0, comm2d, req(6), rc)

    ! message passing to left(i--)
    call MPI_Irecv(A(nx+1, 1), 1, column_y, nbr_right, 1, comm2d, req(6), rc)
    call MPI_Isend(A(1, 1), 1, column_y, nbr_left, 1, comm2d, req(7), rc)

    call MPI_Waitall(8, req, MPI_STATUSES_IGNORE, rc)

end subroutine exchange_message_nonblock

function check_diff(A, A_p, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(8), intent(in) :: A(0:nx+1, 0:ny+1)
    real(8), intent(inout) :: A_p(0:nx+1, 0:ny+1)
    integer :: i, j
    real(8) :: error, check_diff

    error = 0.0d0
    do j = 1, ny
        do i = 1, nx
            error = max( error, abs(A_p(i,j)-A(i,j)) )
        enddo
    enddo

    A_p = A

    check_diff = error

end function check_diff

subroutine swap(A, A_new, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(8), intent(inout) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1)
    integer :: i, j

    do j = 1, ny
        do i = 1, nx
            A(i, j) = A_new(i, j)
        enddo
    enddo

end subroutine swap


!7. Write three functions that compute the sum of the numbers in a list: using a for-loop,
! a while-loop and recursion. (Subject to availability of these constructs in your language of choice.)

    program Exercises
    implicit none
    integer :: list(5)
    integer :: sum

    list = (/ 2, 4, 10, 1, 6 /)

    sum = sum$for(list)
    print '(A, I0, A)', 'The sum computed with a for loop is ', sum, '.'

    sum = sum$while(list)
    print '(A, I0, A)', 'The sum computed with a while loop is ', sum, '.'

    sum = sum$recursive(list)
    print '(A, I0, A)', 'The sum computed recursively is ', sum, '.'

    contains

    function sum$for(list) result(res)
        integer, dimension(:), intent(in) :: list
        integer :: res
        integer :: i

        res = 0
        do i=1, size(list)
            res = res + list(i)
        end do

    end function

    function sum$while(list) result(res)
        integer, dimension(:), intent(in) :: list
        integer :: res
        integer :: i
        ! Fortran has a do-while loop, but it doesn't really match the intent of the question.
        ! It still tests the condition *before* executing the inner block, not after.

        ! The difference between do-while and plain 'do' is
        !   do-while tests a boolean
        !   do (plain) tests that a number is below another number, the common case of C/C++ for loop
        ! So, this function will use other means of control flow to test the loop condition at the end.

        res = 0
        i = 1
10      &
        res = res + list(i)
        i = i + 1
        if (i .le. size(list)) then
            goto 10
        end if

    end function

    recursive function sum$recursive(list) result(res)
        integer, dimension(:), intent(in) :: list
        integer :: res

        res = sum$recursive$impl(list, 1)

    end function

    recursive function sum$recursive$impl(list, currentElementIndex) result(res)
        integer, dimension(:), intent(in) :: list
        integer :: currentElementIndex
        integer :: res

        if (currentElementIndex .gt. size(list)) then
            res = 0
            return
        end if

        res = list(currentElementIndex) + sum$recursive$impl(list, currentElementIndex + 1)

    end function

    end program Exercises


subroutine linspace(x1, x2, dx, n, y)
	implicit none

	real(kind=8), intent(in)                :: x1, x2
	real(kind=8), intent(in)                :: dx
	real(kind=8), intent(out), dimension(:), allocatable :: y
	integer :: n

	integer :: i

	n = ceiling( ( x2 - x1 ) / dx ) + 1

	allocate(y(n))

	y    = (/ ( (x1+i*dx), i=0,n-1 ) /)
	y(n) = min(y(n),x2)

end subroutine linspace

! function dtime()
! 	implicit none

! 	real(kind=8) :: dtime

! 	integer(kind=8) :: clocks

! 	call mkl_get_cpu_clocks( clocks )

! ! 	dtime = mkl_get_clocks_frequency() / clocks
! 	dtime = clocks / mkl_get_clocks_frequency()

! end function dtime