SUBROUTINE JGHCOSIAD(LDTOUQ,KDIM,KM,KSPSTA,KSPEND,YDSPJB)

!**** *JGHCOSIAD*    - INTERFACE TO MULTIPLICATION BY HORIZONTAL INVERSE
!                   MATRIX OF CORRELATIONS ON DESTRETCHED SPHERE (INV ADJ)

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

!        Multitasked division by correlations of stretched model

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

!        *CALL* *JGHCOSIAD(LDTOUQ,KM)*

!        INPUT:
!                LDTOUQ : .TRUE. The Q field may be modified
!                         .FALSE. The Q field is not touched
!                  KDIM : Work array dimension
!                    KM : Zonal wavenumber to process
!                KSPSTA : First spectral coefficients handled
!                KSPEND : Last spectral columns handled

!     METHOD.
!     -------
!        1) Convert spectral coeffs to destretched sphere
!        2) Multiply by homogeneous inverse correlations
!        3) Return coeffs to work sphere

!     EXTERNALS.
!     ----------
!        SPDICOAD

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

!        ECMWF Research Department documentation of the IFS

!     AUTHOR.
!     -------

!        F. Bouttier   *CNRM/GMAP*

!     MODIFICATIONS.
!     --------------

!        ORIGINAL      95-02-13
!        L.Isaksen     95-06-06   Reordering of spectral arrays
!        Mats Hamrud   95-12-15   Remove NFGM .ne. 1, cleaning
!        F.Veerse      95-10-12   NFLEV/NFLSUR correction
!        L.Isaksen     96-05-05   Adapted for Message passing
!        E.Holm        97-09-08   Included ozone
!        M.Hamrud      03-08-01   GFL introduction
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVL   ,NFLSUR   ,NSPEC2   ,NCMAX    ,&
 & NCPEC2   ,NTMAX    ,NTPEC2  
USE YOMLUN   , ONLY : NULOUT   ,NULDILA  ,NULCONT
USE YOMLAP   , ONLY : NACM0    ,NATM0    ,NSTREL !! ,NCVALUE  
!!USE YOM_YGFL , ONLY : YGFL     ,YQ       ,YO3
USE SPECTRAL_FIELDS_MOD

IMPLICIT NONE

LOGICAL           ,INTENT(IN)    :: LDTOUQ 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDIM 
INTEGER(KIND=JPIM),INTENT(IN)    :: KM 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSPSTA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSPEND 
TYPE(SPECTRAL_FIELD), INTENT(INOUT) :: YDSPJB

REAL(KIND=JPRB) :: ZTBUF(KDIM,NTPEC2), ZCBUF(KDIM,NCPEC2)
REAL(KIND=JPRB) :: ZCVOR(NFLSUR,NCPEC2), ZCDIV(NFLSUR,NCPEC2)
REAL(KIND=JPRB) :: ZCT(NFLSUR,NCPEC2)
!!REAL(KIND=JPRB) :: ZCGFL(NFLSUR,NCPEC2,YGFL%NUMSPFLDSJB)
REAL(KIND=JPRB) :: ZCSP(NCPEC2)

INTEGER(KIND=JPIM) :: IADD, ICMXSUR, ITMXSUR, JL, JS
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
!#include "jghcori.intfb.h"
#include "spdicoad.intfb.h"

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

!*    1.    TRANSFER COEFFICIENTS TO WORK ARRAYS
!           ------------------------------------

!       Set top of triangle to zero 
IF (LHOOK) CALL DR_HOOK('JGHCOSIAD',0,ZHOOK_HANDLE)
ZTBUF(:,:)=0.0_JPRB

!       Concatenate all fields for vectorization

DO JL=1,NFLEVL
  DO JS=1,NSPEC2
    ZTBUF(JL,NSTREL(JS))=YDSPJB%VOR(JL,JS)
    ZTBUF(NFLEVL+JL,NSTREL(JS))=YDSPJB%DIV(JL,JS)
    ZTBUF(NFLEVL*2+JL,NSTREL(JS))=YDSPJB%TEM(JL,JS)
  ENDDO
ENDDO
IADD=NFLEVL*3
IF (LDTOUQ .AND. ASSOCIATED(YDSPJB%HUM)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NSPEC2
      ZTBUF(IADD+JL,NSTREL(JS))=YDSPJB%HUM(JL,JS)
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF (ASSOCIATED(YDSPJB%OZN)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NSPEC2
      ZTBUF(IADD+JL,NSTREL(JS))=YDSPJB%OZN(JL,JS)
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF(IADD > KDIM) CALL ABOR1('ERROR, JGHCOSIAD 100: KDIM')

!*    2.    GO TO DESTRETCHED SPHERE
!           ------------------------

ITMXSUR=NTMAX+1+MOD(NTMAX,2)
ICMXSUR=NCMAX+1+MOD(NCMAX,2)
CALL SPDICOAD(NULCONT,NULOUT,IADD,KDIM,&
 & NTMAX,ITMXSUR,NATM0,NTPEC2,&
 & NCMAX,ICMXSUR,NACM0,NCPEC2,&
 & KM,-1,ZTBUF,ZCBUF)  

!*    3.    MULTIPLY BY CORRELATIONS
!           ------------------------

!        3.1. Deconcatenate in truncation ncmax

DO JL=1,NFLEVL
  DO JS=1,NCPEC2
    ZCVOR(JL,JS)=ZCBUF(JL,JS)
    ZCDIV(JL,JS)=ZCBUF(NFLEVL+JL,JS)
    ZCT(JL,JS)=ZCBUF(NFLEVL*2+JL,JS)
  ENDDO
ENDDO
IADD=NFLEVL*3
IF (LDTOUQ .AND. ASSOCIATED(YDSPJB%HUM)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NCPEC2
call abor1('broken')
!!      ZCGFL(JL,JS,YQ%MPSPJB)=ZCBUF(IADD+JL,JS)
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF (ASSOCIATED(YDSPJB%OZN)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NCPEC2
call abor1('broken')
!!      ZCGFL(JL,JS,YO3%MPSPJB)=ZCBUF(IADD+JL,JS)
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF(IADD > KDIM) CALL ABOR1('ERROR, JGHCOSIAD 310: KDIM')

!       3.2 Multiply

!          Remember JGHCORI is selfadjoint
!=== Mike Fisher: sort this out
!!!CALL JGHCORI(LDTOUQ,ZCVOR,ZCDIV,ZCT,ZCGFL,ZCSP,KSPSTA,KSPEND,NCVALUE)
CALL ABOR1 ('Interface to JGHCOR is broken')

!       3.3 Reconcatenate

DO JL=1,NFLEVL
  DO JS=1,NCPEC2
    ZCBUF(JL,JS)=ZCVOR(JL,JS)
    ZCBUF(NFLEVL+JL,JS)=ZCDIV(JL,JS)
    ZCBUF(NFLEVL*2+JL,JS)=ZCT(JL,JS)
  ENDDO
ENDDO
IADD=NFLEVL*3
IF (LDTOUQ .AND. ASSOCIATED(YDSPJB%HUM)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NCPEC2
call abor1('broken')
!!      ZCBUF(IADD+JL,JS)=ZCGFL(JL,JS,YQ%MPSPJB)
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF (ASSOCIATED(YDSPJB%OZN)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NCPEC2
call abor1('broken')
!!      ZCBUF(IADD+JL,JS)=ZCGFL(JL,JS,YO3%MPSPJB)
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF(IADD > KDIM) CALL ABOR1('ERROR, JGHCOSIAD 330: KDIM')

!*    4.    BACK TO WORK SPHERE
!           -------------------

CALL SPDICOAD(NULDILA,NULOUT,IADD,KDIM,&
 & NTMAX,ITMXSUR,NATM0,NTPEC2,&
 & NCMAX,ICMXSUR,NACM0,NCPEC2,&
 & KM,1,ZTBUF,ZCBUF)  

!*    5.    BACK FROM WORK ARRAYS
!           ---------------------

DO JL=1,NFLEVL
  DO JS=1,NSPEC2
    YDSPJB%VOR(JL,JS)=ZTBUF(JL,NSTREL(JS))
    YDSPJB%DIV(JL,JS)=ZTBUF(NFLEVL+JL,NSTREL(JS))
    YDSPJB%TEM(JL,JS)=ZTBUF(NFLEVL*2+JL,NSTREL(JS))
  ENDDO
ENDDO
IADD=NFLEVL*3
IF (LDTOUQ .AND. ASSOCIATED(YDSPJB%HUM)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NSPEC2
      YDSPJB%HUM(JL,JS)=ZTBUF(IADD+JL,NSTREL(JS))
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF (ASSOCIATED(YDSPJB%OZN)) THEN
  DO JL=1,NFLEVL
    DO JS=1,NSPEC2
      YDSPJB%OZN(JL,JS)=ZTBUF(IADD+JL,NSTREL(JS))
    ENDDO
  ENDDO
  IADD=IADD+NFLEVL
ENDIF
IF(IADD > KDIM) CALL ABOR1('ERROR, JGHCOSIAD 500: KDIM')

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