!*==dtrsyl.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DTRSYL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DTRSYL + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
!                          LDC, SCALE, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANA, TRANB
!       INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
!       DOUBLE PRECISION   SCALE
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DTRSYL solves the real Sylvester matrix equation:
!>
!>    op(A)*X + X*op(B) = scale*C or
!>    op(A)*X - X*op(B) = scale*C,
!>
!> where op(A) = A or A**T, and  A and B are both upper quasi-
!> triangular. A is M-by-M and B is N-by-N; the right hand side C and
!> the solution X are M-by-N; and scale is an output scale factor, set
!> <= 1 to avoid overflow in X.
!>
!> A and B must be in Schur canonical form (as returned by DHSEQR), that
!> is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
!> each 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANA
!> \verbatim
!>          TRANA is CHARACTER*1
!>          Specifies the option op(A):
!>          = 'N': op(A) = A    (No transpose)
!>          = 'T': op(A) = A**T (Transpose)
!>          = 'C': op(A) = A**H (Conjugate transpose = Transpose)
!> \endverbatim
!>
!> \param[in] TRANB
!> \verbatim
!>          TRANB is CHARACTER*1
!>          Specifies the option op(B):
!>          = 'N': op(B) = B    (No transpose)
!>          = 'T': op(B) = B**T (Transpose)
!>          = 'C': op(B) = B**H (Conjugate transpose = Transpose)
!> \endverbatim
!>
!> \param[in] ISGN
!> \verbatim
!>          ISGN is INTEGER
!>          Specifies the sign in the equation:
!>          = +1: solve op(A)*X + X*op(B) = scale*C
!>          = -1: solve op(A)*X - X*op(B) = scale*C
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The order of the matrix A, and the number of rows in the
!>          matrices X and C. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix B, and the number of columns in the
!>          matrices X and C. N >= 0.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,M)
!>          The upper quasi-triangular matrix A, in Schur canonical form.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          The upper quasi-triangular matrix B, in Schur canonical form.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N right hand side matrix C.
!>          On exit, C is overwritten by the solution matrix X.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M)
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is DOUBLE PRECISION
!>          The scale factor, scale, set <= 1 to avoid overflow in X.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1: A and B have common or very close eigenvalues; perturbed
!>               values were used to solve the equation (but the matrices
!>               A and B are unchanged).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleSYcomputational
!
!  =====================================================================
      SUBROUTINE DTRSYL(Trana,Tranb,Isgn,M,N,A,Lda,B,Ldb,C,Ldc,Scale,   &
     &                  Info)
      IMPLICIT NONE
!*--DTRSYL168
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trana , Tranb
      INTEGER Info , Isgn , Lda , Ldb , Ldc , M , N
      DOUBLE PRECISION Scale
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , C(Ldc,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL notrna , notrnb
      INTEGER ierr , j , k , k1 , k2 , knext , l , l1 , l2 , lnext
      DOUBLE PRECISION a11 , bignum , da11 , db , eps , scaloc , sgn ,  &
     &                 smin , smlnum , suml , sumr , xnorm
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION dum(1) , vec(2,2) , x(2,2)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      DOUBLE PRECISION DDOT , DLAMCH , DLANGE
      EXTERNAL LSAME , DDOT , DLAMCH , DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , DLALN2 , DLASY2 , DSCAL , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and Test input parameters
!
      notrna = LSAME(Trana,'N')
      notrnb = LSAME(Tranb,'N')
!
      Info = 0
      IF ( .NOT.notrna .AND. .NOT.LSAME(Trana,'T') .AND.                &
     &     .NOT.LSAME(Trana,'C') ) THEN
         Info = -1
      ELSEIF ( .NOT.notrnb .AND. .NOT.LSAME(Tranb,'T') .AND.            &
     &         .NOT.LSAME(Tranb,'C') ) THEN
         Info = -2
      ELSEIF ( Isgn/=1 .AND. Isgn/=-1 ) THEN
         Info = -3
      ELSEIF ( M<0 ) THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -7
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -9
      ELSEIF ( Ldc<MAX(1,M) ) THEN
         Info = -11
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DTRSYL',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      Scale = ONE
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Set constants to control overflow
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = smlnum*DBLE(M*N)/eps
      bignum = ONE/smlnum
!
      smin = MAX(smlnum,eps*DLANGE('M',M,M,A,Lda,dum),                  &
     &       eps*DLANGE('M',N,N,B,Ldb,dum))
!
      sgn = Isgn
!
      IF ( notrna .AND. notrnb ) THEN
!
!        Solve    A*X + ISGN*X*B = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        bottom-left corner column by column by
!
!         A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
!
!        Where
!                  M                         L-1
!        R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
!                I=K+1                       J=1
!
!        Start column loop (index = L)
!        L1 (L2) : column index of the first (first) row of X(K,L).
!
         lnext = 1
         DO l = 1 , N
            IF ( l>=lnext ) THEN
               IF ( l==N ) THEN
                  l1 = l
                  l2 = l
               ELSEIF ( B(l+1,l)/=ZERO ) THEN
                  l1 = l
                  l2 = l + 1
                  lnext = l + 2
               ELSE
                  l1 = l
                  l2 = l
                  lnext = l + 1
               ENDIF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L).
!
               knext = M
               DO k = M , 1 , -1
                  IF ( k<=knext ) THEN
                     IF ( k==1 ) THEN
                        k1 = k
                        k2 = k
                     ELSEIF ( A(k,k-1)/=ZERO ) THEN
                        k1 = k - 1
                        k2 = k
                        knext = k - 2
                     ELSE
                        k1 = k
                        k2 = k
                        knext = k - 1
                     ENDIF
!
                     IF ( l1==l2 .AND. k1==k2 ) THEN
                        suml = DDOT(M-k1,A(k1,MIN(k1+1,M)),Lda,         &
     &                         C(MIN(k1+1,M),l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
                        scaloc = ONE
!
                        a11 = A(k1,k1) + sgn*B(l1,l1)
                        da11 = ABS(a11)
                        IF ( da11<=smin ) THEN
                           a11 = smin
                           da11 = smin
                           Info = 1
                        ENDIF
                        db = ABS(vec(1,1))
                        IF ( da11<ONE .AND. db>ONE ) THEN
                           IF ( db>bignum*da11 ) scaloc = ONE/db
                        ENDIF
                        x(1,1) = (vec(1,1)*scaloc)/a11
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
!
                     ELSEIF ( l1==l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(M-k2,A(k1,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k2,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(l1-1,C(k2,1),Ldc,B(1,l1),1)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        CALL DLALN2(.FALSE.,2,1,smin,ONE,A(k1,k1),Lda,  &
     &                              ONE,ONE,vec,2,-sgn*B(l1,l1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k2,l1) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1==k2 ) THEN
!
                        suml = DDOT(M-k1,A(k1,MIN(k1+1,M)),Lda,         &
     &                         C(MIN(k1+1,M),l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = sgn*(C(k1,l1)-(suml+sgn*sumr))
!
                        suml = DDOT(M-k1,A(k1,MIN(k1+1,M)),Lda,         &
     &                         C(MIN(k1+1,M),l2),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l2),1)
                        vec(2,1) = sgn*(C(k1,l2)-(suml+sgn*sumr))
!
                        CALL DLALN2(.TRUE.,2,1,smin,ONE,B(l1,l1),Ldb,   &
     &                              ONE,ONE,vec,2,-sgn*A(k1,k1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(M-k2,A(k1,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k1,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l2),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l2),1)
                        vec(1,2) = C(k1,l2) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k2,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(l1-1,C(k2,1),Ldc,B(1,l1),1)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k2,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l2),1)
                        sumr = DDOT(l1-1,C(k2,1),Ldc,B(1,l2),1)
                        vec(2,2) = C(k2,l2) - (suml+sgn*sumr)
!
                        CALL DLASY2(.FALSE.,.FALSE.,Isgn,2,2,A(k1,k1),  &
     &                              Lda,B(l1,l1),Ldb,vec,2,scaloc,x,2,  &
     &                              xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(1,2)
                        C(k2,l1) = x(2,1)
                        C(k2,l2) = x(2,2)
                     ENDIF
                  ENDIF
!
               ENDDO
            ENDIF
!
         ENDDO
!
      ELSEIF ( .NOT.notrna .AND. notrnb ) THEN
!
!        Solve    A**T *X + ISGN*X*B = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        upper-left corner column by column by
!
!          A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
!
!        Where
!                   K-1        T                    L-1
!          R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
!                   I=1                          J=1
!
!        Start column loop (index = L)
!        L1 (L2): column index of the first (last) row of X(K,L)
!
         lnext = 1
         DO l = 1 , N
            IF ( l>=lnext ) THEN
               IF ( l==N ) THEN
                  l1 = l
                  l2 = l
               ELSEIF ( B(l+1,l)/=ZERO ) THEN
                  l1 = l
                  l2 = l + 1
                  lnext = l + 2
               ELSE
                  l1 = l
                  l2 = l
                  lnext = l + 1
               ENDIF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L)
!
               knext = 1
               DO k = 1 , M
                  IF ( k>=knext ) THEN
                     IF ( k==M ) THEN
                        k1 = k
                        k2 = k
                     ELSEIF ( A(k+1,k)/=ZERO ) THEN
                        k1 = k
                        k2 = k + 1
                        knext = k + 2
                     ELSE
                        k1 = k
                        k2 = k
                        knext = k + 1
                     ENDIF
!
                     IF ( l1==l2 .AND. k1==k2 ) THEN
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
                        scaloc = ONE
!
                        a11 = A(k1,k1) + sgn*B(l1,l1)
                        da11 = ABS(a11)
                        IF ( da11<=smin ) THEN
                           a11 = smin
                           da11 = smin
                           Info = 1
                        ENDIF
                        db = ABS(vec(1,1))
                        IF ( da11<ONE .AND. db>ONE ) THEN
                           IF ( db>bignum*da11 ) scaloc = ONE/db
                        ENDIF
                        x(1,1) = (vec(1,1)*scaloc)/a11
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
!
                     ELSEIF ( l1==l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k2),1,C(1,l1),1)
                        sumr = DDOT(l1-1,C(k2,1),Ldc,B(1,l1),1)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        CALL DLALN2(.TRUE.,2,1,smin,ONE,A(k1,k1),Lda,   &
     &                              ONE,ONE,vec,2,-sgn*B(l1,l1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k2,l1) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1==k2 ) THEN
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = sgn*(C(k1,l1)-(suml+sgn*sumr))
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l2),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l2),1)
                        vec(2,1) = sgn*(C(k1,l2)-(suml+sgn*sumr))
!
                        CALL DLALN2(.TRUE.,2,1,smin,ONE,B(l1,l1),Ldb,   &
     &                              ONE,ONE,vec,2,-sgn*A(k1,k1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l1),1)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l2),1)
                        sumr = DDOT(l1-1,C(k1,1),Ldc,B(1,l2),1)
                        vec(1,2) = C(k1,l2) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k2),1,C(1,l1),1)
                        sumr = DDOT(l1-1,C(k2,1),Ldc,B(1,l1),1)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k2),1,C(1,l2),1)
                        sumr = DDOT(l1-1,C(k2,1),Ldc,B(1,l2),1)
                        vec(2,2) = C(k2,l2) - (suml+sgn*sumr)
!
                        CALL DLASY2(.TRUE.,.FALSE.,Isgn,2,2,A(k1,k1),   &
     &                              Lda,B(l1,l1),Ldb,vec,2,scaloc,x,2,  &
     &                              xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(1,2)
                        C(k2,l1) = x(2,1)
                        C(k2,l2) = x(2,2)
                     ENDIF
                  ENDIF
!
               ENDDO
            ENDIF
         ENDDO
!
      ELSEIF ( .NOT.notrna .AND. .NOT.notrnb ) THEN
!
!        Solve    A**T*X + ISGN*X*B**T = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        top-right corner column by column by
!
!           A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L)
!
!        Where
!                     K-1                            N
!            R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T].
!                     I=1                          J=L+1
!
!        Start column loop (index = L)
!        L1 (L2): column index of the first (last) row of X(K,L)
!
         lnext = N
         DO l = N , 1 , -1
            IF ( l<=lnext ) THEN
               IF ( l==1 ) THEN
                  l1 = l
                  l2 = l
               ELSEIF ( B(l,l-1)/=ZERO ) THEN
                  l1 = l - 1
                  l2 = l
                  lnext = l - 2
               ELSE
                  l1 = l
                  l2 = l
                  lnext = l - 1
               ENDIF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L)
!
               knext = 1
               DO k = 1 , M
                  IF ( k>=knext ) THEN
                     IF ( k==M ) THEN
                        k1 = k
                        k2 = k
                     ELSEIF ( A(k+1,k)/=ZERO ) THEN
                        k1 = k
                        k2 = k + 1
                        knext = k + 2
                     ELSE
                        k1 = k
                        k2 = k
                        knext = k + 1
                     ENDIF
!
                     IF ( l1==l2 .AND. k1==k2 ) THEN
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(N-l1,C(k1,MIN(l1+1,N)),Ldc,         &
     &                         B(l1,MIN(l1+1,N)),Ldb)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
                        scaloc = ONE
!
                        a11 = A(k1,k1) + sgn*B(l1,l1)
                        da11 = ABS(a11)
                        IF ( da11<=smin ) THEN
                           a11 = smin
                           da11 = smin
                           Info = 1
                        ENDIF
                        db = ABS(vec(1,1))
                        IF ( da11<ONE .AND. db>ONE ) THEN
                           IF ( db>bignum*da11 ) scaloc = ONE/db
                        ENDIF
                        x(1,1) = (vec(1,1)*scaloc)/a11
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
!
                     ELSEIF ( l1==l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k2),1,C(1,l1),1)
                        sumr = DDOT(N-l2,C(k2,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        CALL DLALN2(.TRUE.,2,1,smin,ONE,A(k1,k1),Lda,   &
     &                              ONE,ONE,vec,2,-sgn*B(l1,l1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k2,l1) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1==k2 ) THEN
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(1,1) = sgn*(C(k1,l1)-(suml+sgn*sumr))
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l2),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l2,MIN(l2+1,N)),Ldb)
                        vec(2,1) = sgn*(C(k1,l2)-(suml+sgn*sumr))
!
                        CALL DLALN2(.FALSE.,2,1,smin,ONE,B(l1,l1),Ldb,  &
     &                              ONE,ONE,vec,2,-sgn*A(k1,k1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l1),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k1),1,C(1,l2),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l2,MIN(l2+1,N)),Ldb)
                        vec(1,2) = C(k1,l2) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k2),1,C(1,l1),1)
                        sumr = DDOT(N-l2,C(k2,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(k1-1,A(1,k2),1,C(1,l2),1)
                        sumr = DDOT(N-l2,C(k2,MIN(l2+1,N)),Ldc,         &
     &                         B(l2,MIN(l2+1,N)),Ldb)
                        vec(2,2) = C(k2,l2) - (suml+sgn*sumr)
!
                        CALL DLASY2(.TRUE.,.TRUE.,Isgn,2,2,A(k1,k1),Lda,&
     &                              B(l1,l1),Ldb,vec,2,scaloc,x,2,xnorm,&
     &                              ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(1,2)
                        C(k2,l1) = x(2,1)
                        C(k2,l2) = x(2,2)
                     ENDIF
                  ENDIF
!
               ENDDO
            ENDIF
         ENDDO
!
      ELSEIF ( notrna .AND. .NOT.notrnb ) THEN
!
!        Solve    A*X + ISGN*X*B**T = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        bottom-right corner column by column by
!
!            A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L)
!
!        Where
!                      M                          N
!            R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T].
!                    I=K+1                      J=L+1
!
!        Start column loop (index = L)
!        L1 (L2): column index of the first (last) row of X(K,L)
!
         lnext = N
         DO l = N , 1 , -1
            IF ( l<=lnext ) THEN
               IF ( l==1 ) THEN
                  l1 = l
                  l2 = l
               ELSEIF ( B(l,l-1)/=ZERO ) THEN
                  l1 = l - 1
                  l2 = l
                  lnext = l - 2
               ELSE
                  l1 = l
                  l2 = l
                  lnext = l - 1
               ENDIF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L)
!
               knext = M
               DO k = M , 1 , -1
                  IF ( k<=knext ) THEN
                     IF ( k==1 ) THEN
                        k1 = k
                        k2 = k
                     ELSEIF ( A(k,k-1)/=ZERO ) THEN
                        k1 = k - 1
                        k2 = k
                        knext = k - 2
                     ELSE
                        k1 = k
                        k2 = k
                        knext = k - 1
                     ENDIF
!
                     IF ( l1==l2 .AND. k1==k2 ) THEN
                        suml = DDOT(M-k1,A(k1,MIN(k1+1,M)),Lda,         &
     &                         C(MIN(k1+1,M),l1),1)
                        sumr = DDOT(N-l1,C(k1,MIN(l1+1,N)),Ldc,         &
     &                         B(l1,MIN(l1+1,N)),Ldb)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
                        scaloc = ONE
!
                        a11 = A(k1,k1) + sgn*B(l1,l1)
                        da11 = ABS(a11)
                        IF ( da11<=smin ) THEN
                           a11 = smin
                           da11 = smin
                           Info = 1
                        ENDIF
                        db = ABS(vec(1,1))
                        IF ( da11<ONE .AND. db>ONE ) THEN
                           IF ( db>bignum*da11 ) scaloc = ONE/db
                        ENDIF
                        x(1,1) = (vec(1,1)*scaloc)/a11
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
!
                     ELSEIF ( l1==l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(M-k2,A(k1,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k2,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(N-l2,C(k2,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        CALL DLALN2(.FALSE.,2,1,smin,ONE,A(k1,k1),Lda,  &
     &                              ONE,ONE,vec,2,-sgn*B(l1,l1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k2,l1) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1==k2 ) THEN
!
                        suml = DDOT(M-k1,A(k1,MIN(k1+1,M)),Lda,         &
     &                         C(MIN(k1+1,M),l1),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(1,1) = sgn*(C(k1,l1)-(suml+sgn*sumr))
!
                        suml = DDOT(M-k1,A(k1,MIN(k1+1,M)),Lda,         &
     &                         C(MIN(k1+1,M),l2),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l2,MIN(l2+1,N)),Ldb)
                        vec(2,1) = sgn*(C(k1,l2)-(suml+sgn*sumr))
!
                        CALL DLALN2(.FALSE.,2,1,smin,ONE,B(l1,l1),Ldb,  &
     &                              ONE,ONE,vec,2,-sgn*A(k1,k1),ZERO,x, &
     &                              2,scaloc,xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(2,1)
!
                     ELSEIF ( l1/=l2 .AND. k1/=k2 ) THEN
!
                        suml = DDOT(M-k2,A(k1,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(1,1) = C(k1,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k1,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l2),1)
                        sumr = DDOT(N-l2,C(k1,MIN(l2+1,N)),Ldc,         &
     &                         B(l2,MIN(l2+1,N)),Ldb)
                        vec(1,2) = C(k1,l2) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k2,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l1),1)
                        sumr = DDOT(N-l2,C(k2,MIN(l2+1,N)),Ldc,         &
     &                         B(l1,MIN(l2+1,N)),Ldb)
                        vec(2,1) = C(k2,l1) - (suml+sgn*sumr)
!
                        suml = DDOT(M-k2,A(k2,MIN(k2+1,M)),Lda,         &
     &                         C(MIN(k2+1,M),l2),1)
                        sumr = DDOT(N-l2,C(k2,MIN(l2+1,N)),Ldc,         &
     &                         B(l2,MIN(l2+1,N)),Ldb)
                        vec(2,2) = C(k2,l2) - (suml+sgn*sumr)
!
                        CALL DLASY2(.FALSE.,.TRUE.,Isgn,2,2,A(k1,k1),   &
     &                              Lda,B(l1,l1),Ldb,vec,2,scaloc,x,2,  &
     &                              xnorm,ierr)
                        IF ( ierr/=0 ) Info = 1
!
                        IF ( scaloc/=ONE ) THEN
                           DO j = 1 , N
                              CALL DSCAL(M,scaloc,C(1,j),1)
                           ENDDO
                           Scale = Scale*scaloc
                        ENDIF
                        C(k1,l1) = x(1,1)
                        C(k1,l2) = x(1,2)
                        C(k2,l1) = x(2,1)
                        C(k2,l2) = x(2,2)
                     ENDIF
                  ENDIF
!
               ENDDO
            ENDIF
         ENDDO
!
      ENDIF
!
!
!     End of DTRSYL
!
      END SUBROUTINE DTRSYL


MODULE ghost_mod
  use constants_mod
  use parameters_mod
  use projection_mod
  use mesh_mod
  use stat_mod

  implicit none

  ! ghost location
  type ghostLocation
    real   , dimension(:,:), allocatable :: X     ! X coordinate of ghost points
    real   , dimension(:,:), allocatable :: Y     ! Y coordinate of ghost points, not needed in interpolation
    real   , dimension(:,:), allocatable :: coef  ! Position in cell
    integer, dimension(:,:), allocatable :: iref  ! Index of reference point
  end type ghostLocation

  type(ghostLocation) :: ghost
  contains

  subroutine initGhost
    integer :: i,j
    integer :: iPatch ! computational patch
    integer :: gpatch ! ghost patch
    integer :: ihalo  ! halo index
    real    :: lambda, theta
    real    :: coef
    integer :: iref

    real    :: X_RAW(Nx+1)

    allocate(ghost%X   (ids:ide,nPVHalo))
    allocate(ghost%Y   (ids:ide,nPVHalo))
    allocate(ghost%coef(ids:ide,nPVHalo))
    allocate(ghost%iref(ids:ide,nPVHalo))

    ! Calculate ghost points location
    iPatch = 1
    gpatch = 5
    do j = jde+1, jpe
      do i = ids, ide
        ihalo = j - jde
        call pointProjPlane2Sphere(lambda          , theta           , mesh%xP(i,j,iPatch), mesh%yP(i,j,iPatch), iPatch)
        call pointProjSphere2Plane(ghost%X(i,ihalo), ghost%Y(i,ihalo), lambda             , theta              , gPatch)
      enddo
    enddo

    do i = 1, Nx+1
      X_RAW(i) = mesh%xP(pvIdx(1,i),1,iPatch)
    enddo

    ! Calculate reference points
    ! Now apply linear interpolation to obtain edge components
    DO j = 1, nPVHalo
      ! Reset the reference index
      iref = 1

      DO i = ids, ide
        !
        ! Find reference points
        !
        DO WHILE (ghost%X(i,j) > X_RAW(iref))
          iref = iref + 1
        ENDDO

        IF ((ghost%X(i,j) >= X_RAW(iref-1)) .AND. (ghost%X(i,j) <= X_RAW(iref  )))THEN

          coef = ghost%X(i,j) - X_RAW(iref-1)

          ghost%coef(i,j) = coef
          ghost%iref(i,j) = iref - 1
        ELSE
          print*,'Ghost cell location error'
          stop
        ENDIF
      ENDDO
    ENDDO

  end subroutine initGhost

  !------------------------------------------------------------------------------
  ! SUBROUTINE CubedSphereFillHalo
  !
  ! Description:
  !   Recompute the cubed sphere data storage array, with the addition of a
  !   halo region around the specified panel.
  !------------------------------------------------------------------------------
  SUBROUTINE CubedSphereFillHalo(field)

    IMPLICIT NONE

    REAL, DIMENSION(ips:ipe,jps:jpe,ifs:ife), INTENT(INOUT) :: field

    REAL, DIMENSION(ids:ide,jds:jde,ifs:ife) :: field_inner

    ! Local variables
    INTEGER :: i

    !zarg = 0.0 !DBG
    field_inner = field(ids:ide,jds:jde,ifs:ife)

    ! Equatorial panels
    !IF (np==1) THEN
       DO i=1,nPVHalo
          field(1-i    ,jds:jde,1) = field_inner(ide-i  ,jds:jde,4)  !exchange left
          field(ide+i  ,jds:jde,1) = field_inner(i+1    ,jds:jde,2)  !exchange right
          field(ids:ide,1-i    ,1) = field_inner(ids:ide,jde-i  ,6)  !exchange below
          field(ids:ide,jde+i  ,1) = field_inner(ids:ide,i+1    ,5)  !exchange over
       ENDDO
    !ELSE IF (np==2) THEN
       DO i=1,nPVHalo
          field(1-i    ,jds:jde,2) = field_inner(ide-i  ,jds:jde   ,1)  !exchange left
          field(ide+i  ,jds:jde,2) = field_inner(i+1    ,jds:jde   ,3)  !exchange right
          field(ids:ide,1-i    ,2) = field_inner(ide-i  ,jde:jds:-1,6)  !exchange below
          field(ids:ide,jde+i  ,2) = field_inner(ide-i  ,jds:jde   ,5)  !exchange over
       ENDDO
    !ELSE IF (np==3) THEN
       DO i=1,nPVHalo
          field(1-i    ,jds:jde,3) = field_inner(ide-i     ,jds:jde,2)  !exchange left
          field(ide+i  ,jds:jde,3) = field_inner(i+1       ,jds:jde,4)  !exchange right
          field(ids:ide,1-i    ,3) = field_inner(ide:ids:-1,i+1    ,6)  !exchange below
          field(ids:ide,jde+i  ,3) = field_inner(ide:ids:-1,jde-i  ,5)  !exchange over
       ENDDO
    !ELSE IF (np==4) THEN
       DO i=1,nPVHalo
          field(1-i    ,jds:jde,4) = field_inner(ide-i     ,jds:jde   ,3) !exchange left
          field(ide+i  ,jds:jde,4) = field_inner(i+1       ,jds:jde   ,1) !exchange right
          field(ids:ide,1-i    ,4) = field_inner(i+1       ,jds:jde   ,6) !exchange below
          field(ids:ide,jde+i  ,4) = field_inner(i+1       ,jde:jds:-1,5) !exchange over
       ENDDO
    ! Top panel
    !ELSE IF (np==5) THEN
       DO i=1,nPVHalo
          field(1-i    ,jds:jde,5) = field_inner(ide:ids:-1,jde-i,4) !exchange left
          field(ide+i  ,jds:jde,5) = field_inner(ids:ide   ,jde-i,2) !exchange right
          field(ids:ide,1-i    ,5) = field_inner(ids:ide   ,jde-i,1) !exchange below
          field(ids:ide,jde+i  ,5) = field_inner(ide:ids:-1,jde-i,3) !exchange over
       ENDDO
    ! Bottom panel
    !ELSE IF (np==6) THEN
       DO i=1,nPVHalo
          field(1-i    ,jds:jde,6) = field_inner(ids:ide   ,i+1  ,4) !exchange left
          field(ide+i  ,jds:jde,6) = field_inner(ide:ids:-1,i+1  ,2) !exchange right
          field(ids:ide,1-i    ,6) = field_inner(ide:ids:-1,i+1  ,3) !exchange below
          field(ids:ide,jde+i  ,6) = field_inner(ids:ide   ,i+1  ,1) !exchange over
       ENDDO
    !ELSE
    !   WRITE (*,*) 'Fatal error: In CubedSphereFillHalo'
    !   WRITE (*,*) 'Invalid panel id ', np
    !   STOP
    !ENDIF
  END SUBROUTINE CubedSphereFillHalo

  subroutine CubedSphereFillGhost(field)
    real, intent(inout) :: field(ips:ipe,jps:jpe,ifs:ife)

    real ghost_target(ips:ipe,jps:jpe,ifs:ife)

    integer i,j,iPatch

    ghost_target                          = FillValue
    ghost_target(ids:ide,jds:jde,ifs:ife) = field(ids:ide,jds:jde,ifs:ife)

    call CubedSphereFillHalo(field)

    do iPatch = ifs, ife
      do j = 1, nPVHalo
        ! Left boundary
        call linear_interp(ghost_target(ids-j,jds:jde,iPatch),field(ids-j,jds:jde,iPatch),ghost%iref(:,j),ghost%coef(:,j))
        ! Rigth boundary
        call linear_interp(ghost_target(ide+j,jds:jde,iPatch),field(ide+j,jds:jde,iPatch),ghost%iref(:,j),ghost%coef(:,j))
        ! Top boundary
        call linear_interp(ghost_target(ids:ide,jde+j,iPatch),field(ids:ide,jde+j,iPatch),ghost%iref(:,j),ghost%coef(:,j))
        ! Bottom boundary
        call linear_interp(ghost_target(ids:ide,jds-j,iPatch),field(ids:ide,jds-j,iPatch),ghost%iref(:,j),ghost%coef(:,j))
      enddo
    enddo

    field = ghost_target

  end subroutine CubedSphereFillGhost

  subroutine linear_interp(dest,src,iref,coef)
    real   , intent(out) :: dest(ids:ide)
    real   , intent(in ) :: src (ids:ide)
    integer, intent(in ) :: iref(ids:ide)
    real   , intent(in ) :: coef(ids:ide)

    integer i
    integer P1,P2,P3,P4
    real    q1,q2,q3,q4

#   ifdef MCV3
    ! For MCV3 only
    do i = ids,ide
      P1 = pvIdx(1,iref(i))
      P2 = pvIdx(2,iref(i))
      P3 = pvIdx(3,iref(i))

      q1 = src(P1)
      q2 = src(P2)
      q3 = src(P3)

      dest(i) = q1 - (3.*q1 - 4.*q2 + q3)*coef(i) / dx + 2.*(q1 - 2.*q2 + q3)*coef(i)**2 / (dx**2)

    enddo
#   endif

#   ifdef MCV4
    ! For MCV4 only
    do i = ids,ide
      P1 = pvIdx(1,iref(i))
      P2 = pvIdx(2,iref(i))
      P3 = pvIdx(3,iref(i))
      P4 = pvIdx(4,iref(i))

      q1 = src(P1)
      q2 = src(P2)
      q3 = src(P3)
      q4 = src(P4)

      dest(i) = (2.*dx**3.*q1 + dx**2.*(-11.*q1 + 18.*q2 - 9.*q3 + 2.*q4) * coef(i) + 9.*dx*(2.*q1 - 5.*q2 + 4.*q3 - q4)*coef(i)**2. + 9.*(-q1 + 3.*q2 - 3.*q3 + q4)*coef(i)**3.) / (2.*dx**3.)

    enddo
#   endif

  end subroutine linear_interp

  ! Fill up halo with ghost points
  subroutine fill_ghost(stat)
    type(stat_field), intent(inout) :: stat

    call CubedSphereFillGhost(stat%phi            )
    call CubedSphereFillGhost(stat%zonal_wind     )
    call CubedSphereFillGhost(stat%meridional_wind)

  end subroutine fill_ghost

END MODULE ghost_mod


include "remap_1d_grid2grid.f90"

subroutine remap_2d_grid2grid(x1min, x1max, x1grid, y1min, y1max, y1grid &
  , x2min, x2max, x2grid, y2min, y2max, y2grid, xpixlen, ypixlen, f1, f2)

  ! Remaps field 1 onto field 2 using exact weights.
  !
  ! Parameters
  ! ----------
  ! x1min : float
  !   Minimum x in grid 1.
  ! x1max : float
  !   Maximum x in grid 1.
  ! x1grid : int
  !   Number of grid points in grid 1 along x.
  ! y1min : float
  !   Minimum y in grid 1.
  ! y1max : float
  !   Maximum y in grid 1.
  ! y1grid : int
  !   Number of grid points in grid 1 along y.
  ! x2min : float
  !   Minimum x in grid 2.
  ! x2max : float
  !   Maximum x in grid 2.
  ! x2grid : int
  !   Number of grid points in grid 2 along x.
  ! y2min : float
  !   Minimum y in grid 2.
  ! y2max : float
  !   Maximum y in grid 2.
  ! y2grid : int
  !   Number of grid points in grid 2 along y.
  ! xpixlen : int
  !   Length of pixel mapping indices and weights along x.
  ! ypixlen : int
  !   Length of pixel mapping indices and weights along y.
  ! f1 : array
  !   Values on grid 1.
  !
  ! Returns
  ! -------
  ! f2 : array
  !   Remapped field 1 onto field 2.

  implicit none

  ! Parameter declarations

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: x1grid, y1grid, x2grid, y2grid, xpixlen, ypixlen
  real(kind=dp), intent(in) :: x1min, x1max, x2min, x2max
  real(kind=dp), intent(in) :: y1min, y1max, y2min, y2max
  real(kind=dp), intent(in) :: f1(x1grid*y1grid)
  real(kind=dp), intent(out) :: f2(x2grid*y2grid)
  real(kind=dp) :: xweights(xpixlen), yweights(ypixlen)
  integer :: xpix(xpixlen), ypix(ypixlen), pix(xpixlen*ypixlen), i, j, xwhich2pix, ywhich2pix, ii, jj, i1, j1

  ! Function

  do i = 1, x2grid

    xwhich2pix = i-1
    call remap_1d_grid2grid_pixel(x1min, x1max, x1grid, x2min, x2max, x2grid, xwhich2pix, xpixlen, xpix, xweights)

    do j = 1, y2grid

      ywhich2pix = j-1
      call remap_1d_grid2grid_pixel(y1min, y1max, y1grid, y2min, y2max, y2grid, ywhich2pix, ypixlen, ypix, yweights)

      call pix1dto2d(xpix, ypix, xpixlen, ypixlen, y1grid, pix)

      ii = ywhich2pix + y2grid*xwhich2pix + 1
      f2(ii) = 0.

      jj = 1

      do i1 = 1, xpixlen
        do j1 = 1, ypixlen

          if (pix(jj) .NE. -1) then
            f2(ii) = f2(ii) + xweights(i1)*yweights(j1)*f1(pix(jj)+1)
          end if

          jj = jj + 1

        end do
      end do

    end do
  end do

end subroutine remap_2d_grid2grid


module constant
implicit none

! system precision
integer, parameter :: icha = 1024 ! character length
integer, parameter :: inum = 8 ! precision of real value

! constants
real(inum), parameter :: pi = dacos(-1d0)

end module

module para
use constant
implicit none

! file operation
character(icha) :: inputFileName
character(icha) :: fileNamePure

! trajectory
integer :: Natom, Nframe, Natom3 ! Natom3 = 3*Natom
real(inum), allocatable :: coord(:,:,:) ! 3 (xyz) * Natom * Nframe
real(inum), allocatable :: coord1D(:,:) ! Natom3 * Nframe
character(icha), allocatable :: eleName(:) ! Natom

! covariance matrix
real(inum), allocatable :: coordMean(:) ! Natom3
real(inum), allocatable :: cov(:,:) ! Natom3 * Natom3
real(inum), allocatable :: PCvalue(:), PCvector(:,:)

! project to PC
integer, parameter :: iPC = 3
real(inum), allocatable :: PCA(:,:)

end module

! get extension from a file name
! source : https://stackoverflow.com/a/36736660
subroutine getExtension(fileName, fileNameReal, extension)
use constant
implicit none
character(len=*), intent(in) :: fileName
character(icha), intent(out) :: fileNameReal, extension
integer :: ppos, fileNameLength

    fileNameLength = len(trim(fileName))
    ppos = scan(trim(fileName), '.', BACK=.true.)
    if ( ppos > 0 ) then
        fileNameReal = fileName(1:ppos-1)
        extension = fileName(ppos+1:fileNameLength)
    end if

end subroutine

! calculate eigenvalue and eigenvector
! N : size of matrix
! matIn : matrix(N,N)
! evReal : real eigenvalue(N)
! ev : eigenvector(N,N)
subroutine calcEigenvector(N, matIn, evReal, ev)
use lapack95, only: geev
integer, intent(in) :: N
real(8), intent(in) :: matIn(N,N)
real(8), intent(out) :: evReal(N)
real(8) :: evImag(N)
real(8) :: evl(N,N), evr(N,N)
real(8) :: work(N*N)
real(8), intent(out) :: ev(N,N)
integer :: info, i

    call dgeev('V','V',N,matIn,N,evReal,evImag,evl,N,evr,N,work,N*4,info)
    ev(1:N,1:N) = evl(1:N,1:N)

end subroutine

! matrix-matrix product
subroutine matrixMul(m, k, n, A, B, C)
!use lapack95, only: dgemm
!use blas95, only: gemm
use constant
implicit none
integer, intent(in) :: m, n, k
real(inum), intent(in) :: A(m,k), B(k,n)
real(inum), intent(inout) :: C(m,n)
integer :: maxSize

    maxSize = maxval( (/m,n,k/) )
    !write(*,*) maxSize
    call dgemm('N', 'N', m, n, k, 1d0, A, M, B, K, 0d0, C, M)
    !call gemm(A, B, C)

end subroutine

! log error and exit whole program
subroutine logError(content)
implicit none
character(len=*), intent(in) :: content

    print *, '[ERROR] ', content
    stop

end subroutine

subroutine logWarn(content)
implicit none
character(len=*), intent(in) :: content

    print *, '[WARNING] ', content

end subroutine