!-------------------------------------- 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:
* Bin He *ARMA/MRB* Nov. 2011.
* - Replaced MXMA8 with DGEMUL of ESSL.
*
#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"
#include "dgemul.h"
*
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
c CALL MXMA8(EIGEN2,1,NKSDIM2, SQRTIN2,1,NKSDIM2, RESULT2,1,
c + NKSDIM2,NKSDIM2,NKSDIM2,NKSDIM2)
CALL DGEMUL(EIGEN2,NKSDIM2,'N',SQRTIN,NKSDIM2,'N',RESULT2,
+ NKSDIM2,NKSDIM2,NKSDIM2,NKSDIM2)
c CALL MXMA8(RESULT2,1,NKSDIM2, EIGEN,NKSDIM2,1, RESULT,1,
c + NKSDIM2,NKSDIM2,NKSDIM2,NKSDIM2)
CALL DGEMUL(RESULT2,NKSDIM2,'N',EIGEN,NKSDIM2,'N',RESULT,
+ 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