!-------------------------------------- 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 SUCORNS2 2,4
        IMPLICIT NONE
#if defined (DOC)
*
***s/r  SUCORNS2 - 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
*                - matrix used in SPA2GD, SPA2GDAD
*               ***Version of SUCORNS adapted only for NANALVAR=4    
*               ***for new PtoT approach with localized Tb correlations
*               ***Created May 2008 by M. Buehner          
*
*Author  : M. Buehner November 97
*Revision:
*          S. Pellerin *ARMA/SMC May 2000
*                   . Check for negative eigenvalues
*          JM Belanger CMDA/SMC  Aug 2000 
*                   . 32 bits conversion
*                    (MXMA8, DSYEV instead of MXMA, SSYEV)
*          C. Charette CMDA/SMC  Mar. 2010
*                   . Added logical key LLDEBUG
*                     Replaced etiket 'CORNS' by 'CORRNS' in fstinf
*                     statement just before fstecr of array CORVERT
*
#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"
*
      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
      INTEGER IER,ILWORK,INFO,KLATPTOT(NLATBIN)
ccc plug in
      integer iulcorvert, ikey
ccc plug in
C
      REAL*8 RESULT(NKSDIM2,NKSDIM2),RESULT2(NKSDIM2,NKSDIM),ZWORK(1)
      REAL*8 ZTT(NFLEV,NFLEV,(NTRUNC+1)),ZTPSI(NFLEV,NFLEV,(NTRUNC+1))
      REAL*8 ZPS,ZTLEN,ZCORR,ZR,ZLC,ZPRES1,ZPRES2,ZPROF(JPNFLEV)
      REAL*8 ZFACT,ZFACT2,ZCORIOLIS,ZPSIPS(NFLEV)
      REAL*8 ZPSI(NFLEV,NFLEV),ZWINDOW(NJ),ZFACTTB(NJ,NFLEV),ZFACTPSB(NJ)
      LOGICAL LLDEBUG
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
      LLDEBUG = .false.
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,*)'  SUCORNS2 --- Calculate CORNS^(0.5)'
C
        ILWORK=4*NKSDIM2*2
        iulcorvert = 0
        ierr = fnom(iulcorvert,'corvert.fst','RND',0)
        ierr = fstouv(iulcorvert,'RND')
c
      if(nlatbin.eq.1) then
        klatptot(1)=1
      elseif(nlatbin.eq.3) then
        klatptot(1)=1
        klatptot(2)=nj/2
        klatptot(3)=nj
      endif
c
      DO JLATBIN=1,NLATBIN
      write(nulout,*) 'KLATPTOT=',jlatbin,klatptot(jlatbin)

      if(lldebug) then
        DO II=1,NFLEV
          DO II2=1,NFLEVPTOT
            write(622,*) ii,ii2,klatptot(jlatbin),ptot(ii,ii2
     &         ,KLATPTOT(JLATBIN))
          enddo
        enddo
      endif
c
c explicitly compute the balanced temperature and temperature-psi correlations
c
      DO IN=0,NTRUNC
C
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
              EIGEN(II,IJ)=0.0
           END DO
        END DO
        DO IJ=1,NFLEV
           DO II=1,NFLEV
              ZTPSI(II,IJ,IN+1)=0.0
              ZTT(II,IJ,IN+1)=0.0
           END DO
        END DO
        DO IJ=1,NFLEVPTOT
          DO II=1,NFLEV
            DO II2=1,NFLEVPTOT
              ZTPSI(II,IJ,IN+1)=ZTPSI(II,IJ,IN+1)+PTOT(II,II2,KLATPTOT(JLATBIN))*CORNS(II2,IJ,IN,JLATBIN)
            ENDDO
          ENDDO
        ENDDO
        IF(NFLEVPTOT.lt.NFLEV) THEN
          DO IJ=(NFLEVPTOT+1),NFLEV
            DO II=1,NFLEV
              ZTPSI(II,IJ,IN+1)=ZTPSI(II,NFLEVPTOT,IN+1)
            ENDDO
          ENDDO
        ENDIF
        DO IJ=1,NFLEV
          DO II=1,NFLEV
            DO II2=1,NFLEVPTOT
              ZTT(II,IJ,IN+1)=ZTT(II,IJ,IN+1)+ZTPSI(II,II2,IN+1)*PTOT(IJ,II2,KLATPTOT(JLATBIN))
            ENDDO
          ENDDO
        ENDDO
      ENDDO

      if(lldebug) then
        write(620,*) ZTT
        write(621,*) ZTPSI
      endif
c
c fill in blocks for balance temperature
c
      do in=0,ntrunc
        DO IJ=1,NFLEV
          DO II=1,NFLEV
            CORNS(NKSDIM+II,NKSDIM+IJ,IN,JLATBIN)=ZTT(II,IJ,IN+1)
            CORNS(       II,NKSDIM+IJ,IN,JLATBIN)=ZTPSI(IJ,II,IN+1)
            CORNS(NKSDIM+II,       IJ,IN,JLATBIN)=ZTPSI(II,IJ,IN+1)
          ENDDO
        ENDDO
      enddo
c
c Save un-localized PSI correlations
c
      DO JK2 = 1, NFLEV
        DO JK1 = 1, NFLEV
          ZPSI(JK1,JK2) = 0.0
          DO IN = 0, NTRUNC
            ZPSI(JK1,JK2) = ZPSI(JK1,JK2)+((2*IN+1)*CORNS(JK1,JK2,IN,JLATBIN))
          ENDDO
        ENDDO
      ENDDO
C
C Apply vertical localization to corrns
C
      zps = 101000. 0
      call calcpres(ZPROF,vhybinc,nflev,ZPS,rptopinc
     &             ,rprefinc,rcoefinc,1)
C
      do jk1=1,nflev
        write(nulout,*)'sucorns2:lev,hyb,zprof,log= ',jk1,vhybinc(jk1)
     &              ,zprof(jk1),log(zprof(jk1))
      enddo
c
c unbalanced temperature
c
      if(JLATBIN.eq.2) then
        ztlen=2.0d0
      else
        ztlen=RVLOCUNBALT
      endif
      write(nulout,*)'sucorns2:ztlen(UNBALT)= ',ztlen,' latbin=',jlatbin
      if(ztlen.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        do jk1=1,nflev
          zpres1=log(ZPROF(jk1))
          do jk2=1,nflev
            ZLC=ztlen/2.0
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              corns(jk1+2*nflev,jk2+2*nflev,IN,jlatbin)  =corns(jk1+2*nflev,jk2+2*nflev,IN,jlatbin)*zcorr
            enddo
          enddo
        enddo
      endif
c
c balanced temperature
c
      if(JLATBIN.eq.2) then
        ztlen=2.0d0
      else
        ztlen=RVLOCBALT
      endif
      write(nulout,*)'sucorns2:ztlen(BALT)= ',ztlen,' latbin=',jlatbin
      if(ztlen.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        ZLC=ZTLEN/2.0
        do jk1=1,nflev
          zpres1=log(ZPROF(jk1))
          do jk2=1,nflev
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              corns(jk1+nksdim,jk2+nksdim,IN,jlatbin)  =corns(jk1+nksdim,jk2+nksdim,IN,jlatbin)*zcorr
            enddo
          enddo
        enddo
      endif
c
c streamfunction 
c
      ztlen= RVLOCPSI    ! specify length scale (in units of ln(Pressure))
      if(JLATBIN.eq.2) ztlen=3.0d0
      write(nulout,*)'sucorns2:ztlen(PSI)= ',ztlen,jlatbin
      if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        ZLC=ZTLEN/2.0
        do jk1=1,nflev
          zpres1=log(ZPROF(jk1))
          do jk2=1,nflev
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              corns(jk1,jk2,IN,jlatbin)  =corns(jk1,jk2,IN,jlatbin)*zcorr
            enddo
          enddo
        enddo
      endif
c
c temp-psi cross-correlations
c
      ztlen= RVLOCPSITT    ! specify length scale (in units of ln(Pressure))
      if(JLATBIN.eq.2) ztlen=3.0d0
      write(nulout,*)'sucorns2:ztlen(PSI-TT)= ',ztlen,jlatbin
      if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        ZLC=ZTLEN/2.0
        do jk1=1,nflev
          zpres1=log(ZPROF(jk1))
          do jk2=1,nflev
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              corns(jk1,jk2+nksdim,IN,jlatbin)=corns(jk1,jk2+nksdim,IN,jlatbin)*zcorr
              corns(jk1+nksdim,jk2,IN,jlatbin)=corns(jk1+nksdim,jk2,IN,jlatbin)*zcorr
            enddo
          enddo
        enddo
      endif
c
c velocity potential (unbalanced)
c
      ztlen= RVLOCCHI    ! specify length scale (in units of ln(Pressure))
      if(JLATBIN.eq.2) ztlen=3.0d0
      write(nulout,*)'sucorns2:ztlen(CHI)= ',ztlen,jlatbin
      if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        ZLC=ZTLEN/2.0
        do jk1=1,nflev
          if(jk1.gt.nflev) then
            zpres1=log(ZPROF(nflev))
          else
            zpres1=log(ZPROF(jk1))
          endif
          do jk2=1,nflev
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              corns(jk1+nflev,jk2+nflev,IN,jlatbin)  =corns(jk1+nflev,jk2+nflev,IN,jlatbin)*zcorr
            enddo
          enddo
        enddo
      endif
c
c cross-correlation t'-ps'
c
      if(.true.) then
      ztlen= RVLOCUNBALT    ! specify length scale (in units of ln(Pressure))
      if(JLATBIN.eq.2) ztlen=2.0d0
      write(nulout,*)'sucorns2:ztlen(UNBALT)= ',ztlen,jlatbin
      if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        ZLC=ZTLEN/2.0
        do jk1=1,nflev
          if(jk1.gt.nflev) then
            zpres1=log(ZPROF(nflev))
          else
            zpres1=log(ZPROF(jk1))
          endif
          do jk2=1,nflev
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              if(jk1.eq.nflev) then
                corns(1+4*nflev,jk2+2*nflev,IN,jlatbin)  =corns(1+4*nflev,jk2+2*nflev,IN,jlatbin)*zcorr
                corns(jk2+2*nflev,1+4*nflev,IN,jlatbin)  =corns(jk2+2*nflev,1+4*nflev,IN,jlatbin)*zcorr
              endif
            enddo
          enddo
        enddo
      endif
      endif
c
c humidity
c
      ztlen= RVLOCLQ    ! specify length scale (in units of ln(Pressure))
      if(JLATBIN.eq.2) ztlen=2.0d0
      write(nulout,*)'sucorns2:ztlen(LQ)= ',ztlen,jlatbin
      if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
        ZLC=ZTLEN/2.0
        do jk1=1,nflev
          if(jk1.gt.nflev) then
            zpres1=log(ZPROF(nflev))
          else
            zpres1=log(ZPROF(jk1))
          endif
          do jk2=1,nflev
            zpres2=log(ZPROF(jk2))
            ZR = abs(zpres2 - zpres1)
            if(ZR.le.ZLC) then
              zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              zcorr= 0.0
            endif
            if(zcorr.lt.0.0) zcorr=0.0
            do in=0,ntrunc
              corns(jk1+3*nflev,jk2+3*nflev,IN,jlatbin)  =corns(jk1+3*nflev,jk2+3*nflev,IN,jlatbin)*zcorr
            enddo
          enddo
        enddo
      endif
c
c compute total vertical correlations (including for balanced temperature)
c
      if(.true.) then
        DO JK2 = 1, NKSDIM2
          DO JK1 = 1, NKSDIM2
            CORVERT(JK1,JK2) = 0.0
            DO IN = 0, NTRUNC
              CORVERT(JK1,JK2) = CORVERT(JK1,JK2)+((2*IN+1)*CORNS(JK1,JK2,IN,jlatbin))
            ENDDO
          ENDDO
            if(jk2.ge.320 .and. jk2.le. 400) then
              print*,'corvert:jk2,corvert(jk2,jk2)= ',JK2
     &             ,CORVERT(JK2,JK2)
            endif
        ENDDO

        if(lldebug) then
          write(701,*) corvert
          write(702,*) zpsi
        endif

        if(.true.) then
          ikey =fstinf(NULBGST,ini,inj,ink,-1,'CORRNS',-1,0,-1,' ','ZZ')
          ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits
     &         ,idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp
     &         ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1,iextr2
     &         ,iextr3)
c
          ini = nksdim2
          inj = nksdim2
          ink = 1
          ip1 = jlatbin
          ip2 = ntrunc
          ip3 = 0
          clnomvar= 'ZV'
          cletiket= 'CORVERT'
          idatyp  = 5
c
          ierr = vfstecr(corvert, corvert, -inbits, iulcorvert, idateo
     &         , ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar,
     &         clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp,
     &         .true.)
          ierr = vfstlir(corvert,iulcorvert,INI,INJ,INK
     S       ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
          DO JK2 = 1, NKSDIM2
            if(jk2.ge.320 .and. jk2.le. 400) then
              print*,'corvert lire:jk2,corvert(jk2,jk2)= ',JK2
     &             ,CORVERT(JK2,JK2)
            endif
        ENDDO

        endif
c
c Modify RGSIGTB to obtain correct sigma_Tb
c
        ZWINDOW(:)=0.0d0
        CALL SUWINLATBIN(ZWINDOW,JLATBIN)
        do jk1=1,nflev          
          zfact=corvert(jk1+nksdim,jk1+nksdim)
          do ij=1,nj
            zcoriolis = abs(2.*romega*rmu(ij))
            if(zfact.gt.0.0.and.zcoriolis.ne.0.0) then
              zfact2=1/(zfact*zcoriolis*zcoriolis)
            else 
              zfact2=0.0
            endif
            if(lldebug) then
              write(801,*) jk1,ij,zwindow(ij),zfact2
            endif
            zfacttb(ij,jk1)=zfacttb(ij,jk1)+(zwindow(ij)*zwindow(ij)*zfact2)
          enddo
        enddo
c
c Modify RGSIGPSB to obtain correct sigma_PSb
c
        do ij=1,nj
          do jk2=1,nflevptot
            zpsips(jk2)=0.0d0
            do jk1=1,nflevptot
              zpsips(jk2)=zpsips(jk2)+ptot(NFLEV+1,jk1,klatptot(jlatbin))*zpsi(jk1,jk2)
            enddo
          enddo
          zfact=0.0d0
          do jk1=1,nflevptot
            zfact=zfact+ptot(NFLEV+1,jk1,klatptot(jlatbin))*zpsips(jk1)
          enddo
          zcoriolis = abs(2.*romega*rmu(ij))
          if(zfact.gt.0.0.and.zcoriolis.ne.0.0) then
            zfact2=1/(zfact*zcoriolis*zcoriolis)
          else 
            zfact2=0.0
          endif
          if(lldebug) then
            write(802,*) ij,zwindow(ij),zfact2
          endif
          zfactpsb(ij)=zfactpsb(ij)+(zwindow(ij)*zwindow(ij)*zfact2)
        enddo
      endif
c
      enddo ! end loop on jlatbin
c
c
c Modify RGSIGTB and RGSIGPSB to obtain correct sigma_Tb and sigma_Psb
c
      do ij=1,nj
        if(zfactpsb(ij).gt.0.0) then
          rgsigpsb(ij)=rgsigpsb(ij)*sqrt(zfactpsb(ij))
        else
          rgsigpsb(ij)=0.0
        endif          
        do jk1=1,nflev          
          if(zfacttb(ij,jk1).gt.0.0) then
            rgsigtb(ij,jk1)=rgsigtb(ij,jk1)*sqrt(zfacttb(ij,jk1))
          else
            rgsigtb(ij,jk1)=0.0
          endif
        enddo
      enddo

      DO JLATBIN=1,NLATBIN
c
c compute square-root of corns
c
      do in=0,ntrunc
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
              EIGEN(II,IJ)=CORNS(II,IJ,IN,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(IN.eq.12) write(nulout,*) 'SUCORNS2: 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,NKSDIM,NKSDIM)
cbue        CALL MXMA8(RESULT2,1,NKSDIM2,  EIGEN,NKSDIM2,1,  RESULT,1,
cbue     +       NKSDIM2,NKSDIM2,NKSDIM2,NKSDIM2)
C
        DO IJ=1,NKSDIM2
           DO II=1,NKSDIM2
              CORNS(II,IJ,IN,jlatbin)=0.0
           ENDDO
        ENDDO
        DO IJ=1,NKSDIM
           DO II=1,NKSDIM2
              CORNS(II,IJ,IN,jlatbin)=RESULT2(II,IJ)
           ENDDO
        ENDDO
C
      enddo
c
      enddo ! end loop on jlatbin
c
      ierr = fstfrm(iulcorvert)
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