!-------------------------------------- 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 sucornsla2(pcorns) 3
        IMPLICIT NONE
#if defined (DOC)
*
***s/r  sucornsla2 - Following sucorns2.ftn from global case:
*                  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=4
*
*Author  :
*Revision:
*
#endif
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
#include "comfftla.cdk"
*
      real*8 pcorns(nksdim2,nksdim2,0:nband-1,1)
      REAL*8 EIGENV(NKSDIM2), EIGEN(NKSDIM2,NKSDIM2),EIGEN2(NKSDIM2,NKSDIM2),
     &       SQRTIN(NKSDIM2,NKSDIM2),SQRTIN2(NKSDIM2,NKSDIM2)
C
      INTEGER IJ,II,II2,IN,JK1,JK2,JR,JLATBIN,jband
      INTEGER IER,ILWORK,INFO,KLATPTOT(NLATBIN)
C
      REAL*8 RESULT(NKSDIM2,NKSDIM2),RESULT2(NKSDIM2,NKSDIM),ZWORK(1)
c
      POINTER(PXWRK,ZWORK)
      POINTER(PXRES,RESULT)
      POINTER(PXRES2,RESULT2)
      POINTER(PXEV,EIGENV)
      POINTER(PXE,EIGEN)
      POINTER(PXSQI,SQRTIN)
      POINTER(PXE2,EIGEN2)
      POINTER(PXSQI2,SQRTIN2)

      EXTERNAL DSYEV
C
C
C    0.  Memory allocation
C
        CALL HPALLOC(PXWRK, 2*4*NKSDIM2, IER,8)
        CALL HPALLOC(PXRES,4*NKSDIM2*NKSDIM2, IER,8)
        CALL HPALLOC(PXRES2,4*NKSDIM2*NKSDIM2, IER,8)
        CALL HPALLOC(PXEV,4*NKSDIM2, IER,8)
        CALL HPALLOC(PXE,4*NKSDIM2*NKSDIM2, IER,8)
        CALL HPALLOC(PXSQI,4*NKSDIM2*NKSDIM2, IER,8)
        CALL HPALLOC(PXE2,4*NKSDIM2*NKSDIM2, IER,8)
        CALL HPALLOC(PXSQI2,4*NKSDIM2*NKSDIM2, IER,8)
C
        write(NULOUT,*)'  *******************************'
        WRITE(NULOUT,*)'  SUCORNSLA2 --- Calculate CORNS^(0.5)'
C
        ILWORK=4*NKSDIM2*2
c
      DO JLATBIN=1,NLATBIN
c
c compute square-root of corns
c
      do jband = 1, nband
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
              EIGEN(II,IJ)=pcorns(II,IJ,jband-1,jlatbin)
           END DO
        END DO
C
C   1.  CALCULATE EIGENVALUES AND EIGENVECTORS.
C
        CALL DSYEV('V','U',NKSDIM2, EIGEN,NKSDIM2, EIGENV,
     +             ZWORK, ILWORK, INFO )
C
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
              SQRTIN(II,IJ)=0.
           END DO
        END DO
C
        DO II=1,NKSDIM2
          if(EIGENV(II).lt.1.0e-15) then
            sqrtin(ii,ii) = 0.0
          else
            SQRTIN(II,II)=SQRT(EIGENV(II))
          endif
          IF(jband.eq.3) write(nulout,*) 'SUCORNSLA2: E-VALUES=',II,EIGENV(II)
        END DO
c
c Reverse the order of E-values and vectors
c
        DO IJ=1,NKSDIM2
          SQRTIN2(IJ,IJ)=SQRTIN(NKSDIM2-IJ+1,NKSDIM2-IJ+1)            
          DO II=1,NKSDIM2
            EIGEN2(II,IJ) =EIGEN(II,NKSDIM2-IJ+1)            
          ENDDO
        ENDDO
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
        CALL MXMA8(EIGEN2,1,NKSDIM2,  SQRTIN2,1,NKSDIM2,  RESULT2,1,
     +       NKSDIM2,NKSDIM2,NKSDIM2,NKSDIM2)
!     +       NKSDIM2,NKSDIM2,NKSDIM,NKSDIM)
        CALL MXMA8(RESULT2,1,NKSDIM2,  EIGEN,NKSDIM2,1,  RESULT,1,
     +       NKSDIM2,NKSDIM2,NKSDIM2,NKSDIM2)
C
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
              pcorns(II,IJ,jband-1,jlatbin)=0.0
           ENDDO
        ENDDO
!cluc        DO IJ=1,NKSDIM
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
!cluc              pcorns(II,IJ,jband-1,jlatbin)=RESULT2(II,IJ)
              pcorns(II,IJ,jband-1,jlatbin)=RESULT(II,IJ)
           ENDDO
        ENDDO
C
      enddo
c
      enddo ! end loop on jlatbin
c
      CALL HPDEALLC(PXWRK, IER,1)
      CALL HPDEALLC(PXRES, IER,1)
      CALL HPDEALLC(PXEV, IER,1)
      CALL HPDEALLC(PXE, IER,1)
      CALL HPDEALLC(PXSQI, IER,1)
      CALL HPDEALLC(PXE2, IER,1)
      CALL HPDEALLC(PXSQI2, IER,1)
C
      RETURN
      END