SUBROUTINE EIGENMD(PMATRIX,PMODES,PEIGENV,KDIM,LDEVI,LDEVN,LDEVZ)

!**** *EIGENMD*   - Computes eigenvalues and eigenvectors

!     Purpose.
!     --------

!     Method.
!     -------
!           Computes eigenvalues and eigenvectors of a square matrix
!           PMATRIX of dimension KDIM. The eigenvalues and eigenvectors
!           are ordered. The eigenvectors are normalized and their sign's are
!           fixed so as to ensure reproducibility of the final matrix of
!           normal modes. A matrix of normal modes PMODES is constructed.

!**   Interface.
!     ----------
!        *CALL* *EIGENMD(PMATRIX,PMODES,KDIM)*

!        Explicit arguments :
!        --------------------
!           Input:
!                   PMATRIX  -  Square matrix of dimension KDIM
!                   KDIM     -  Dimension of square matrix PMATRIX
!           Output:
!                   PMODES   -  Matrix of normalized eigenvectors of the
!                               matrix PMATRIX
!                   PEIGENV  -  Vector of eigenvalues of the matrix PMATRIX
!                   LDEVI    -  At least one of the eigenvalues is not real
!                   LDEVN    -  At least one of the eigenvalues is negative real
!                   LDEVZ    -  At least one of the eigenvalues is zero

!        Implicit arguments :
!        --------------------
!        None

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------
!     EIGSOL - An interface to RG (an eigenvalue/vector solver in EISPACK)
!     SCORDO - sort eigenvalues/vectors
!     MINV   - sort eigenvalues/vectors

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Bill Heckley  *ECMWF*

!     Modifications.
!     --------------
!        None
!        2000-09-13 M.Fisher: don't square-root the eigenvalues
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        K.Yessad (Nov 2006): add output logical variables saying
!         if the matrix to be diagonalised has real negative or
!         imaginary eigenvalues.
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

!     ------------------------------------------------------------------

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KDIM 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PMATRIX(KDIM,KDIM) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PMODES(KDIM,KDIM) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PEIGENV(KDIM) 
LOGICAL           ,INTENT(OUT)   :: LDEVI
LOGICAL           ,INTENT(OUT)   :: LDEVN
LOGICAL           ,INTENT(OUT)   :: LDEVZ

!     ------------------------------------------------------------------

INTEGER(KIND=JPIM), EXTERNAL :: ISAMAX

INTEGER(KIND=JPIM) :: IWO(KDIM)

REAL(KIND=JPRB) :: ZA(KDIM,KDIM),  ZFR(KDIM), ZFI(KDIM)
REAL(KIND=JPRB) :: ZMO(KDIM,KDIM), ZWO(KDIM)

INTEGER(KIND=JPIM) :: IER, ISIGN, J, JI, JJ, JL1, JL2

REAL(KIND=JPRB) :: ZSUM, ZSUMI, ZTES, ZEPS
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!     ------------------------------------------------------------------

#include "abor1.intfb.h"
#include "eigsol.h"
#include "scordo.intfb.h"

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('EIGENMD',0,ZHOOK_HANDLE)

!     ------------------------------------------------------------------

!*       1.   SOLVE EIGEN PROBLEM
!             -------------------
DO JL1=1,KDIM
  DO JL2=1,KDIM
    ZA(JL1,JL2) = PMATRIX(JL1,JL2)
  ENDDO
ENDDO

CALL EIGSOL(KDIM,KDIM,ZA,ZFR,ZFI,1,ZMO,IWO,ZWO,IER)
IF(IER /= 0)THEN
  CALL ABOR1('ABORT IN EIGENMD AFTER CALL TO RG')
ENDIF

!     ------------------------------------------------------------------

!*       2.   ORDER THE MODES
!             ---------------
CALL SCORDO(KDIM,ZFR,ZFI,ZMO,ZA)
DO JL1=1,KDIM
  DO JL2=1,KDIM
    PMODES(JL1,KDIM+1-JL2) = ZMO(JL1,JL2)
  ENDDO
ENDDO
DO JL1=1,KDIM
  PEIGENV(KDIM+1-JL1) = ZFR(JL1)
ENDDO

! If the non-zero imaginary parts of the eigenvalues are negligible
! compared to their real counterparts, we reset them to zero.
ZEPS=1.E-13_JPRB
DO JL1=1,KDIM
  IF (ABS(ZFI(JL1)) < ZEPS*ABS(ZFR(JL1))) ZFI(JL1)=0.0_JPRB
ENDDO



ZTES = ZFI(ISAMAX(KDIM,ZFI,1))

! * Is there at least one eigenvalue which is not real?
LDEVI=(ZTES /= 0.0_JPRB)

! * Is there at least one eigenvalue which is real negative?
LDEVN=(MINVAL(ZFR) < 0.0_JPRB)

! * Is there at least one eigenvalue which is equal to 0?
LDEVZ=(MINVAL(ABS(ZFR)) == 0.0_JPRB)

!     ------------------------------------------------------------------

!*       3.   NORMALIZE THE MODES
!             -------------------
DO J=1,KDIM
  ZSUM = 0.0_JPRB
  DO JJ=1,KDIM
    ZSUM = ZSUM + PMODES(JJ,J)*PMODES(JJ,J)
  ENDDO
  ZSUMI = 1.0_JPRB/SQRT(ZSUM)
  DO JJ=1,KDIM
    PMODES(JJ,J) = PMODES(JJ,J)*ZSUMI
  ENDDO
ENDDO

!     ------------------------------------------------------------------

!*       4.   CHECK THE SIGNS OF THE MODES
!             ----------------------------
DO J=1,KDIM
  ISIGN = +1
  IF (PMODES(KDIM,J) < 0.0_JPRB) ISIGN = -ISIGN
  IF (ISIGN == -1) THEN
    DO JI=1,KDIM
      PMODES(JI,J) = - PMODES(JI,J)
    ENDDO
  ENDIF
ENDDO
DO JL1=1,KDIM
  DO JL2=1,KDIM
    ZMO(JL1,JL2) = PMODES(JL1,JL2)
  ENDDO
ENDDO

!     ------------------------------------------------------------------

!*       5.   PRINT OUT INFORMATION ON THE MODES
!             ----------------------------------
!        WRITE(*,510) (J,PEIGENV(J),J=1,KDIM)
! 510     FORMAT('1SQRT OF EIGENVALUES ',/,('0',20X,I4,G13.5))
!         ZCOND = (PEIGENV(1)/PEIGENV(KDIM))**2
!        WRITE(*,'('' CONDITION NUMBER = '',G20.5)') ZCOND
!        WRITE(*,'('' As a rule of thumb, one can expect the '',
!    1      ''computer to lose '',I10,'' decimal places to'',/,
!    2      '' roundoff errors in Gaussian elimination '',
!    3      ''calculations.'')') NINT(LOG10(ZCOND))
!        WRITE(*,520) ZTES
! 520     FORMAT(///'0LARGEST IMAGINARY PART OF EIGENVALUES:',G13.5)
!         IF (ZTES.NE.0) THEN
!          WRITE(*,FMT='('' IMAGINARY PARTS OF EIGENVALUES'')')
!          WRITE(*,FMT='(14(1X,E8.2))')(ZFI(KDIM+1-J),J=1,KDIM)
!         ENDIF

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('EIGENMD',1,ZHOOK_HANDLE)
END SUBROUTINE EIGENMD

