!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!

        SUBROUTINE sucorns_3 7,2
        IMPLICIT NONE
#if defined (DOC)
*
***s/r  sucorns_3  - produce matrix that scales and rotates controls according to
*                  eigenmodes/values of CORNS to create new control vector that
*                  diagonalize the Jb term
*                - this matrix is phi*lambda^-0.5 where phi and lambda are the
*                  eigenvectors and eigenvalues of the background covariance matrix
*                - called from SUCOV when NANALVAR=3
*
*Author  : Luc Fillion  ARMA/EC 
*Revision:
*   Luc Fillion - ARMA/EC - Fev 2004 - Introduce LAM4D analysis and compatibility with global code.
*   Luc Fillion - ARMA/EC - 15 Aug 2007 - Update lam4d to v_10_0_3.
*   Luc Fillion - ARMA/EC - 12 Jan 2009 - Update lam4d to v_10_1_2.
*   Luc Fillion - ARMA/EC - 1 Jun 2009 - Update lam4d to v_10_2_2 and rebaptise sucornsla_3 to sucorns_3
*                 to allow both global and lam in mode nanalvar = 3 (i.e. doing the same things).
*                 Vertical localization in previous v_10_2_2 mode sucorns.ftn is now assmed done in stats step.
*                 Otherwise, replace sucorns_3.ftn by sucorns.ftn to revert back to 10_2_2 mode.
*   Luc Fillion - ARMA/EC - 26 Aug 2009 - Include abort if INFO .ne. 0 ion output of Eigen solver:
*                   LAPACK documentation, P. 211, 1992.
*                 - Test reconstruction of CORNS.
*                 - Remove some hpalloc, dealloc.
*
*    Bin He.    - ARMA/MRB   Nov. 2011 
*                - Replaced MXMA8 with DGEMUL of ESSL. 
#endif
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comgrd.cdk"
#include "comfftla.cdk"
#include "comgrd_param.cdk"
#include "dgemul.h"
*
      REAL*8 EIGENV(NKSDIM), EIGEN(NKSDIM,NKSDIM)
      real*8 SQRTIN(NKSDIM,NKSDIM)
      REAL*8 EIGEN2(NKSDIM,NKSDIM)
C
      INTEGER IJ,II,IN,jband
      integer idum1,idum2,idum3,idum4
      INTEGER IER,ILWORK,INFO
C
      real*8 zmin,zmax
      REAL*8 RESULT(NKSDIM,NKSDIM),RESULT2(NKSDIM,NKSDIM),ZWORK(1)
      real*8 zwmatv1(nksdim,nksdim), zwmatv2(nksdim,nksdim)
      real*8 zwmatv3(nksdim,nksdim)

      real*8 ztol
c
      POINTER(PXWRK,ZWORK)

      EXTERNAL DSYEV 
!
      ztol = 0.0
C
C
C    0.  Memory allocation
C
        CALL HPALLOC(PXWRK, 2*4*NKSDIM, IER,8)
C
        write(NULOUT,*)'  *******************************'
        WRITE(NULOUT,*)'  sucorns_3 --- Calculate CORNS^(0.5)'
C
        ILWORK=4*NKSDIM*2
!
!  calculate CORNS^(0.5) for each total wave number
!
      DO jband=1,nband
!
        DO IJ=1,NKSDIM
           DO II=1,NKSDIM
              EIGEN(II,IJ)=CORNS(II,IJ,jband-1,1)
           END DO
        END DO
!
!   1.  CALCULATE EIGENVALUES AND EIGENVECTORS.
!
!        call initma (zwmatv2,EIGEN,EIGENV,zwmatv1,zwmatv3,nksdim,nksdim,'D') ! input zwmatv1 destroyed
!
        CALL DSYEV('V','U',NKSDIM, EIGEN,NKSDIM, EIGENV,   ! ascending eigenvalues if INFO = 0 on exit
     +             ZWORK, ILWORK, INFO )
!
        if(info.ne.0) then
          CALL ABORT3D(NULOUT,'sucorns_3: DSYEV failed: Program stops')
        endif
C
        DO IJ=1,NKSDIM
           DO II=1,NKSDIM
              SQRTIN(II,IJ)=0.
           END DO
        END DO
C
        DO II=1,NKSDIM
          if(EIGENV(II).lt.ztol) then
            sqrtin(ii,ii) = 0.0
!            write(nulout,*) 'sucorns_3: ii,EIGENV(II)=',ii,EIGENV(II)
          else
            SQRTIN(II,II)=SQRT(EIGENV(II))
!            SQRTIN(II,II)=(EIGENV(II))  ! use for testing reconstruction of corns
          endif
        END DO
C
C    2. CALCULATE THE PRODUCT AND STORE IT BACK IN CORNS
C
CCC-- INSERER COMMENTAIRES POUR EXPLIQUER LA DIFFERENCE ENTRE LES 2 APPROCHES
C     POUR L'INSTANT ON FAIT LA DISTINCTION  POUR REPRODUIRE LES RESULTATS
C    QUAND CVCORD .EQ. 'PRESS'
C     VOIR LUC ET MARK
CCC
C
cj        CALL MXMA8(EIGEN,1,NKSDIM,  SQRTIN,1,NKSDIM,  RESULT2,1,
cj     +       NKSDIM,NKSDIM,NKSDIM,NKSDIM)
        CALL DGEMUL(EIGEN,NKSDIM,'N',SQRTIN,NKSDIM,'N',RESULT2,
     +       NKSDIM,NKSDIM,NKSDIM,NKSDIM)  

c        CALL MXMA8(RESULT2,1,NKSDIM,  EIGEN,NKSDIM,1,  RESULT,1,
c     +       NKSDIM,NKSDIM,NKSDIM,NKSDIM)
        CALL DGEMUL(RESULT2,NKSDIM,'N',EIGEN,NKSDIM,'N',RESULT,
     +       NKSDIM,NKSDIM,NKSDIM,NKSDIM)
C
        DO IJ=1,NKSDIM
           DO II=1,NKSDIM
              CORNS(II,IJ,jband-1,1)=RESULT(II,IJ)
           ENDDO
        ENDDO
        write(nulout,*) 'sucorns_3: Band nb. ',jband
        call maxmin(result,nksdim,1,nksdim,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sucorns_3      ',
     &              'CO')
!
      enddo  ! jband
!
        CALL HPDEALLC(PXWRK, IER,1)
!
        RETURN
        END