SUBROUTINE JGVCOR(PSP3DG,PSP2DG,KSPSTA,KSPEND,LDIR)

!**** *JGVCOR*    - TRANSFORMATION OF MODEL FIELDS

!     PURPOSE.
!     --------

!           PROJECT ONTO THE EIGENVECTORS OF THE VERTICAL PREDICTION
!           ERROR CORRELATION MATRICES
!           AND MULTIPLY OR DIVIDE BY THE SQUARE ROOT OF THE EIGENVALUES

!**   INTERFACE.
!     ----------

!        *CALL* *JGVCOR(...)*

!        PSP3DG  Columns of 3d variables                (input/output)
!        PSP2DG  2d variables                           (input/output)
!        KSPSTA  First Spectral column                  (input)
!        KSPEND  Last Spectral column                   (input)
!        LDIR    T=> multiply by eigenvalues, F=> divide (input)

!     METHOD.
!     -------

!     EXTERNALS.
!     ----------
!             *MATMUL* = Fortran 90 intrinsic
!             *MXVA*   = Matrix times Vector

!     REFERENCE.
!     ----------

!        ECMWF Research Department documentation of the IFS

!     AUTHOR.
!     -------

!        E. ANDERSSON  *ECMWF*

!     MODIFICATIONS.
!     --------------
!     Original: 94-03-03 CVART1I based on CVARU1I by BILL HECKLEY
!     Modified  94-09-20 F. Bouttier : rename to JGVCORI (to do only vert
!                                  correls) and multitask on M (not N)
!     Modified  95-06-06 L.Isaksen  Reordering of spectral arrays
!     Modified  95-12-15 M.Hamrud   Removed ref. to LNONSEP
!     Modified  96-05-05 L.Isaksen  Adapted for Message Passing
!     Modified  96-07-25 E.Andersson Fujitsu vectorisation
!     Modified  96-08-27 J. Derber  Implement Ps correlations
!     Modified  97-09-05 E. Holm    Included ozone
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        B.Chapnik 03-Mar-2006 Phasing w/ 30R2, merging w/ ejgvcor
!     NEC         11-Dec-2007 Optimizations
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCT0   , ONLY : LELAM
USE YOMDIM   , ONLY : NFLEVG, NSMAX, NMSMAX
USE YOMJG    , ONLY : N_SPJB_VARS, SPJB_VARS_INFO, VCORS
USE YOMMP    , ONLY : MYSETV   ,NPTRSV
USE YOMLAP   , ONLY : NVALUE
USE YEMLAP   , ONLY : MVALUE
USE YOMGRB   , ONLY : NGRBT, NGRBLNSP
!USE YOM_YGFL , ONLY : YQ
USE YOMGSTATS, ONLY : LSYNCSTATS
IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSP3DG(:,:,:) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSP2DG(:,:) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSPSTA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSPEND 
LOGICAL,           INTENT(IN)    :: LDIR
! === END OF INTERFACE BLOCK ===
!REAL(KIND=JPRB) :: ZSPG(NFLEVG+1,KSPSTA:KSPEND) ! +1 for bank conflicts NEC
!REAL(KIND=JPRB) :: ZSPG2(NFLEVG+1,KSPSTA:KSPEND),ZSPG3(NFLEVG+1,KSPSTA:KSPEND)

INTEGER(KIND=JPIM) :: IN, JLEV, JNM,I,J, JFIELD, IPTJB, IPTJB_LNSP, IKSTAR, IM, III
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTEGER(KIND=JPIM) :: III_E(KSPSTA:KSPEND)

#include "fkstar.h"

#include "abor1.intfb.h"

REAL(KIND=JPRB), DIMENSION(:,:), ALLOCATABLE :: Z_PSP3DG_SECTION
REAL(KIND=JPRB), DIMENSION(:,:), ALLOCATABLE :: ZSPG, ZSPG2, ZSPG3
 
!     ------------------------------------------------------------------

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

! Allocate local arrays. In order to avoid memory conflict on the
! NEC, first dimension of arrays has to be odd.

IF (MOD(NFLEVG,2)==0) THEN
   ALLOCATE(ZSPG(NFLEVG+1,KSPSTA:KSPEND))
   ALLOCATE(ZSPG2(NFLEVG+1,KSPSTA:KSPEND))
   ALLOCATE(ZSPG3(NFLEVG+1,KSPSTA:KSPEND))
   ALLOCATE(Z_PSP3DG_SECTION(NFLEVG+1,KSPSTA:KSPEND))
ELSE
   ALLOCATE(ZSPG(NFLEVG,KSPSTA:KSPEND))
   ALLOCATE(Z_PSP3DG_SECTION(NFLEVG,KSPSTA:KSPEND))
   ALLOCATE(ZSPG2(NFLEVG+2,KSPSTA:KSPEND))
   ALLOCATE(ZSPG3(NFLEVG+2,KSPSTA:KSPEND))
ENDIF

!*    1.    LOOP OVER ALL SPECTRAL COLUMNS
!           ------------------------------


IPTJB_LNSP=HUGE(IPTJB_LNSP)
DO JFIELD=1,N_SPJB_VARS
  IF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBLNSP) THEN
    IPTJB_LNSP = SPJB_VARS_INFO(JFIELD)%IPTJB
  ENDIF
ENDDO

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

!*    2.  DIVIDE BY THE SQUARE ROOT OF THE EIGENVALUES AND
!*        TRANSFORM FROM EIGENVECTOR SPACE TO MODEL ETA LEVELS
!         ----------------------------------------------------

! 2945/5/60

 IF (.NOT. LSYNCSTATS) CALL GSTATS(1097,0)
!!OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JNM,IN,I,J,JLEV,JFIELD,IPTJB)

DO JNM=KSPSTA,KSPEND
  IN=NVALUE(JNM-1+NPTRSV(MYSETV))

 IF (LELAM) THEN  
   IM=MVALUE(JNM-1+NPTRSV(MYSETV))
   IKSTAR=FKSTAR(IN,IM,NSMAX,NMSMAX)
   III_E(JNM)=IKSTAR
 ELSE
   III_E(JNM)=IN
 ENDIF
ENDDO
  
  DO JFIELD=1,N_SPJB_VARS
    IPTJB=SPJB_VARS_INFO(JFIELD)%IPTJB

    Z_PSP3DG_SECTION(1:NFLEVG,KSPSTA:KSPEND) = PSP3DG(1:NFLEVG,KSPSTA:KSPEND,IPTJB)

     IF (IPTJB_LNSP==HUGE(IPTJB_LNSP)) THEN
       CALL ABOR1 ('T IS IN Jb, BUT LNSP IS NOT')
     ENDIF


    IF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBT) THEN

!*    UN-BALANCED MASS OR (TEMPERATURE,SURFACE PRESSURE)

!CDIR NOLOOPCHG
      DO JLEV=1,NFLEVG
        DO JNM=KSPSTA,KSPEND
        ZSPG2(JLEV,JNM)=Z_PSP3DG_SECTION(JLEV,JNM)
        ENDDO
      ENDDO

      DO JNM=KSPSTA,KSPEND
         ZSPG2(NFLEVG+1,JNM)=PSP2DG(JNM,IPTJB_LNSP)
      ENDDO

      ZSPG3(:,:)=0.0_JPRB
      DO J=1,NFLEVG+1
!CDIR NOLOOPCHG
        DO I=1,NFLEVG+1
           DO JNM=KSPSTA,KSPEND
            III=III_E(JNM)
            ZSPG3(I,JNM)=ZSPG3(I,JNM)+VCORS(JFIELD)%EVECS(J,I,III)*ZSPG2(J,JNM)
           ENDDO
        ENDDO
      ENDDO

      DO JLEV=1,NFLEVG+1
        IF (LDIR) THEN
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM)
          ZSPG3(JLEV,JNM)=ZSPG3(JLEV,JNM)*VCORS(JFIELD)%EVALS(JLEV,III)
          ENDDO
        ELSE
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM)
          ZSPG3(JLEV,JNM)=ZSPG3(JLEV,JNM)/VCORS(JFIELD)%EVALS(JLEV,III)
          ENDDO
        ENDIF
        DO JNM=KSPSTA,KSPEND
        ZSPG2(JLEV,JNM)=0.0_JPRB
        ENDDO
      ENDDO
      DO J=1,NFLEVG+1
!CDIR NOLOOPCHG
        DO I=1,NFLEVG+1
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM)
          ZSPG2(I,JNM)=ZSPG2(I,JNM)+VCORS(JFIELD)%EVECS(I,J,III)*ZSPG3(J,JNM)
          ENDDO
        ENDDO
      ENDDO
!CDIR NOLOOPCHG
      DO JLEV=1,NFLEVG
        DO JNM=KSPSTA,KSPEND
        Z_PSP3DG_SECTION(JLEV,JNM)=ZSPG2(JLEV,JNM)
        ENDDO
      ENDDO
      DO JNM=KSPSTA,KSPEND
      PSP2DG(JNM,IPTJB_LNSP)=ZSPG2(NFLEVG+1,JNM)
      ENDDO ! JNM

    ELSEIF (.NOT.SPJB_VARS_INFO(JFIELD)%L_IN_SPA2) THEN

!*    3D FIELDS (BUT NOT T)
      
      ZSPG = 0.0_JPRB

      DO J=1,NFLEVG
!CDIR NOLOOPCHG
        DO I=1,NFLEVG
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM)
          ZSPG(I,JNM)= &
             & ZSPG(I,JNM)+VCORS(JFIELD)%EVECS(J,I,III)*Z_PSP3DG_SECTION(J,JNM)
          ENDDO
        ENDDO
      ENDDO

      DO JLEV=1,NFLEVG
        IF (LDIR) THEN
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM) 
          ZSPG(JLEV,JNM)=ZSPG(JLEV,JNM)*VCORS(JFIELD)%EVALS(JLEV,III)
          ENDDO
        ELSE
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM)
          ZSPG(JLEV,JNM)=ZSPG(JLEV,JNM)/VCORS(JFIELD)%EVALS(JLEV,III)
          ENDDO
        ENDIF
        Z_PSP3DG_SECTION(JLEV,:)=0.0_JPRB
      ENDDO
      DO J=1,NFLEVG
!CDIR NOLOOPCHG
        DO I=1,NFLEVG
          DO JNM=KSPSTA,KSPEND
          III=III_E(JNM)
          Z_PSP3DG_SECTION(I,JNM)= &
             & Z_PSP3DG_SECTION(I,JNM)+VCORS(JFIELD)%EVECS(I,J,III)*ZSPG(J,JNM)
          ENDDO
        ENDDO
      ENDDO
 
    ELSEIF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE/=NGRBLNSP) THEN

      DO JNM=KSPSTA,KSPEND
      III=III_E(JNM)

!*    2D FIELDS (BUT NOT LNSP)
      ZSPG(1,JNM)= VCORS(JFIELD)%EVECS(1,1,III)*PSP2DG(JNM,IPTJB)
      IF (LDIR) THEN
        ZSPG(1,JNM)=ZSPG(1,JNM)*VCORS(JFIELD)%EVALS(1,III)
      ELSE
        ZSPG(1,JNM)=ZSPG(1,JNM)/VCORS(JFIELD)%EVALS(1,III)
      ENDIF
      PSP2DG(JNM,IPTJB)= VCORS(JFIELD)%EVECS(1,1,III)*ZSPG(1,JNM)
      ENDDO ! JNM


    ENDIF
    PSP3DG(1:NFLEVG,KSPSTA:KSPEND,IPTJB)=Z_PSP3DG_SECTION(1:NFLEVG,KSPSTA:KSPEND)
  ENDDO
!ENDDO
!!OMP END PARALLEL DO

DEALLOCATE(ZSPG,ZSPG2,ZSPG3,Z_PSP3DG_SECTION)

CALL GSTATS(1097,1)

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

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