SUBROUTINE SUDIL(KNSMAX,KNSMIN,KDGLG,KDGNH,KULDILA,KULCONT,KULOUT,PSTRET,&
 & LDIMST,KNIMES,KFACTM,P_DLMU,PW)  

!**** *SUDIL* - Manage computation of dilatation matrix.

!      Purpose.
!      --------
!               Prepares and manage the computation of the dilatation
!           matrix used in the Schmidt transform.
!**    Interface.
!      ----------
!         *CALL *SUDIL*

!      Explicit arguments.
!      -------------------
!            KNSMAX  - Larger truncation                            (input)
!            KNSMIN  - Smaller truncation                           (input)
!            KDGLG   - Number of latitudes (must be an even number) (input)
!            KDGNH   - KDGLG/2                                      (input)
!            KULDILA - Logical unit for dilatation matrix           (input)
!            KULCONT - Logical unit for contraction matrix          (input)
!            KULOUT  - Logical unit for prints                      (input)
!            PSTRET  - Stretching factor                            (input)
!            LDIMST  - Option of statistics prints when closing     (input)
!                       files containing dilatation matrices.
!            KNIMES  - Mail level for this file.                    (input)
!            KFACTM  - Multiplication factor for this file.         (input)
!            P_DLMU  - Gaussian latitudes                           (input)
!            PW      - Gaussian weights                             (input)

!      Implicit arguments.
!      -------------------

!      Method.
!      -------
!         See documentation.

!      Reference.
!      ----------
!         Arpege note 19 (in French).

!      Externals.
!      ---------
!         Calls SUPLIS,DILAT,LFIAFM,LFIOUV,LFIFER.
!         Called by SU0YOMB.

!      Author.
!      -------
!         Michel Rochas, DMN.

!      Modifications.
!      --------------
!         Original : 91-01-28.
!         Philippe Courtier: 91-08-07 : Changes the Legendre polynomials
!                                       mapping.
!         D. Giard : 92-12-08 : options when opening LFI files.
!         D. Giard : 93-04-01 : NPM --> NPMS
!         K. YESSAD: 93-05-11 : cleaning, comments put into English.
!         K. YESSAD: 93-07-30 : Call to SUPLIS to compute Legendre
!                               polynomials.
!         R. El Khatib: 97-12-03 : portability of LFI
!         M.Hamrud      01-Oct-2003 CY28 Cleaning
!         K. Yessad: Jul 2005 : A-level parallelisation.
!         K. Yessad (Sept 2008): Gaussian lat and weights => dummy arg
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE PARKIND2  ,ONLY : JPRH

USE YOMMP    , ONLY : MYSETW
USE YOMCT0   , ONLY : NPRGPNS  ,NPRGPEW  ,NPRTRW   ,NPRTRV   ,NPROC
USE YOMTAG    ,ONLY : MTAGLM

USE MPL_MODULE

USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN) :: KNSMAX
INTEGER(KIND=JPIM),INTENT(IN) :: KNSMIN
INTEGER(KIND=JPIM),INTENT(IN) :: KDGLG
INTEGER(KIND=JPIM),INTENT(IN) :: KDGNH
INTEGER(KIND=JPIM),INTENT(IN) :: KULDILA
INTEGER(KIND=JPIM),INTENT(IN) :: KULCONT
INTEGER(KIND=JPIM),INTENT(IN) :: KULOUT
REAL(KIND=JPRB),   INTENT(IN) :: PSTRET
LOGICAL,           INTENT(IN) :: LDIMST
INTEGER(KIND=JPIM),INTENT(IN) :: KNIMES
INTEGER(KIND=JPIM),INTENT(IN) :: KFACTM
REAL(KIND=JPRH),   INTENT(IN) :: P_DLMU(KDGLG)
REAL(KIND=JPRB),   INTENT(IN) :: PW(KDGLG)

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

REAL(KIND=JPRH) :: Z_DLMU(KDGLG),Z_DLSINTA(KDGLG)
REAL(KIND=JPRH) :: Z_DLPNM(0:KNSMIN,0:KNSMIN)
REAL(KIND=JPRH) :: Z_DLA(0:KNSMIN),Z_DLI(0:KNSMIN)
REAL(KIND=JPRH) :: Z_DLPNMX(0:KNSMAX,0:KNSMAX)
REAL(KIND=JPRH) :: Z_DLAX(0:KNSMAX),Z_DLIX(0:KNSMAX)
REAL(KIND=JPRH) :: Z_DLSIN,Z_DLTAN

!     ZPNM : Legendre polynomials, small truncation (KNSMIN).
REAL(KIND=JPRB), ALLOCATABLE :: ZPNM(:,:)
!     ZPNMX: Legendre polynomials, large truncation (KNSMAX).
REAL(KIND=JPRB), ALLOCATABLE :: ZPNMX(:,:)
REAL(KIND=JPRB), ALLOCATABLE :: ZPNM_IN(:,:)
REAL(KIND=JPRB), ALLOCATABLE :: ZPNMX_IN(:,:)

REAL(KIND=JPRB) :: ZMU(KDGLG),ZW(KDGLG),ZMAPP(KDGLG)

REAL(KIND=JPRH),ALLOCATABLE :: Z_DLMUL(:),Z_DLSINTAL(:)
REAL(KIND=JPRB),ALLOCATABLE :: ZWL(:)

REAL(KIND=JPRB),ALLOCATABLE :: ZALPHA(:,:),ZBETA(:,:)

!     IRDEB: the address of the Legendre Polynomial ZPNM(n,m) is :
!            ZPNM(.,IRDEB(m)+KNSMIN-n).
INTEGER(KIND=JPIM) :: IRDEB(0:KNSMIN+1)
!     IRDEBX: the address of the Legendre Polynomial ZPNMX(n,m) is :
!             ZPNMX(.,IRDEBX(m)+KNSMAX-n).
INTEGER(KIND=JPIM) :: IRDEBX(0:KNSMIN+1)

INTEGER(KIND=JPIM), PARAMETER :: JPKS=KIND(ZMU)
INTEGER(KIND=JPIM), PARAMETER :: JPKD=KIND(Z_DLMU)

INTEGER(KIND=JPIM) :: IGLS, INAR, INARI, IRP, ISE, JGL, JM, JN, IPNMX
INTEGER(KIND=JPIM) :: JMLOC, IMGLO, IERR, IPNM, JGLLOC, IGLGLO, ITYP, ITAG
INTEGER(KIND=JPIM) :: ID1,ID2

INTEGER(KIND=JPIM) :: IDGNHX
INTEGER(KIND=JPIM) :: IDGNHL0(NPRTRW)
INTEGER(KIND=JPIM) :: IDGNHL
INTEGER(KIND=JPIM) :: IDGLL
INTEGER(KIND=JPIM) :: IPROCGL(KDGLG)
INTEGER(KIND=JPIM) :: IGLG(KDGLG)
INTEGER(KIND=JPIM) :: IGLG0(KDGLG,NPRTRW)

INTEGER(KIND=JPIM) :: INASM0(0:KNSMIN)
INTEGER(KIND=JPIM) :: INPROCM(0:KNSMIN)
INTEGER(KIND=JPIM) :: INUMPP(NPRTRW)
INTEGER(KIND=JPIM) :: INUMP
INTEGER(KIND=JPIM) :: INUMPX
INTEGER(KIND=JPIM) :: IMYMS(KNSMIN+1)
INTEGER(KIND=JPIM) :: IRDEBL(KNSMIN+2)
INTEGER(KIND=JPIM) :: IRDEBXL(KNSMIN+2)
INTEGER(KIND=JPIM) :: IIRDEBL(0:KNSMIN+1)
INTEGER(KIND=JPIM) :: IIRDEBXL(0:KNSMIN+1)
INTEGER(KIND=JPIM) :: IPNML
INTEGER(KIND=JPIM) :: IPNMXL
INTEGER(KIND=JPIM) :: IOPROC

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "dilat.intfb.h"
#include "dilatb.intfb.h"
#include "sump_dila.intfb.h"
#include "sump_dilb.intfb.h"
#include "suplis.intfb.h"
#include "trltom_dil.intfb.h"

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

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

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

!*        1. Initialisations.
!            ----------------

! * Check that there is only A-level of parallelisation.
IERR=0
IF (NPRGPNS /= NPRTRW) IERR=IERR+1
IF (NPRGPNS /= NPROC) IERR=IERR+1
IF (NPRGPEW /= 1) IERR=IERR+1
IF (NPRTRV /= 1) IERR=IERR+1
IF (KDGLG /= 2*KDGNH) IERR=IERR+1

IF (IERR > 0) THEN
  WRITE(KULOUT,*) ' SUDIL: in configuration 911, the following'
  WRITE(KULOUT,*) '  conditions must be fulfilled:'
  WRITE(KULOUT,*) '  NPRGPNS=NPRTRW=NPROC'
  WRITE(KULOUT,*) '  NPRGPEW=1; NPRTRV=1'
  WRITE(KULOUT,*) '  KDGLG=2*KDGNH'
  CALL ABOR1(' SUDIL: ABOR1 CALLED')
ENDIF

! * This must be an IO processor.
IOPROC=1

ITAG = MTAGLM

Z_DLTAN=(1.0_JPRB-REAL(PSTRET,JPKD)**2)/(1.0_JPRB+REAL(PSTRET,JPKD)**2)
Z_DLSIN=2.0_JPRB*REAL(PSTRET,JPKD)/(1.0_JPRB+REAL(PSTRET,JPKD)**2)

Z_DLMU(1:KDGLG)=P_DLMU(1:KDGLG)
ZW(1:KDGLG)=PW(1:KDGLG)

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

!*        2. Computes Legendre Polynomials for truncation KNSMIN.
!            ----------------------------------------------------

!         2.1 Parallelisation environment for latitude distribution.

IF (NPRTRW > 1) THEN
  CALL SUMP_DILA(KDGLG,KDGNH,KULOUT,&
   & IDGNHX,IDGNHL0,IDGNHL,IDGLL,IPROCGL,IGLG,IGLG0)
ENDIF

!         2.2 IRDEB, IRDEBX, IPNM, IPNMX:

DO JM=0,KNSMIN+1
  IRDEBX(JM)=1+(KNSMAX+1)*(KNSMAX+2)/2-(KNSMAX+1-JM)*(KNSMAX+2-JM)/2
  IRDEB(JM)=1+(KNSMIN+1)*(KNSMIN+2)/2-(KNSMIN+1-JM)*(KNSMIN+2-JM)/2
ENDDO

! IPNMX is also equal to (KNSMIN+1)*(KNSMIN+2)/2+(KNSMAX-KNSMIN)*(KNSMIN+1)
IPNMX=IRDEBX(KNSMIN+1)-1

! IPNM is also equal to (KNSMIN+1)*(KNSMIN+2)/2
IPNM=IRDEB(KNSMIN+1)-1

!         2.3 Computation of Legendre polynomials for truncation KNSMIN.

DO JGL=1,KDGNH
  Z_DLSINTA(JGL)=(Z_DLTAN+Z_DLMU(JGL))/(1.0_JPRB+Z_DLTAN*Z_DLMU(JGL))
ENDDO
DO JGL=1,KDGNH
  IGLS=2*KDGNH-JGL+1
  Z_DLSINTA(IGLS)=(Z_DLTAN-Z_DLMU(JGL))/(1.0_JPRB-Z_DLTAN*Z_DLMU(JGL))
ENDDO

IF (NPRTRW > 1) THEN

  ALLOCATE(Z_DLMUL(IDGLL))
  ALLOCATE(ZWL(IDGLL))
  ALLOCATE(Z_DLSINTAL(IDGLL))
  ALLOCATE(ZPNM_IN(IDGLL,IPNM))

  DO JGLLOC=1,IDGLL
    IGLGLO=IGLG(JGLLOC)
    Z_DLMUL(JGLLOC)=Z_DLMU(IGLGLO)
    ZWL(JGLLOC)=ZW(IGLGLO)
    Z_DLSINTAL(JGLLOC)=Z_DLSINTA(IGLGLO)
  ENDDO

  CALL SUPLIS(KNSMIN,KNSMIN,IDGLL,Z_DLSINTAL,.TRUE.,ZPNM_IN, &
   & Z_DLPNM,Z_DLA,Z_DLI)

  DEALLOCATE(Z_DLSINTAL)

ELSE

  ALLOCATE(ZPNM(KDGLG,IPNM))
  CALL SUPLIS(KNSMIN,KNSMIN,KDGLG,Z_DLSINTA,.TRUE.,ZPNM,Z_DLPNM,Z_DLA,Z_DLI)

ENDIF

!         2.4 Computation of Legendre polynomials for truncation KNSMAX,
!             then multiplication by Gauss weights.

IF (NPRTRW > 1) THEN

  ALLOCATE(ZPNMX_IN(IDGNHL,IPNMX))
  CALL SUPLIS(KNSMIN,KNSMAX,IDGNHL,Z_DLMUL,.TRUE.,ZPNMX_IN, &
   & Z_DLPNMX,Z_DLAX,Z_DLIX)

  ISE=0
  DO JM=0,KNSMIN
    DO JN=KNSMAX,JM,-1
      ISE=ISE+1
      DO JGLLOC=1,IDGNHL
        ZPNMX_IN(JGLLOC,ISE)=ZPNMX_IN(JGLLOC,ISE)*ZWL(JGLLOC)
      ENDDO
    ENDDO
  ENDDO

  DEALLOCATE(Z_DLMUL)
  DEALLOCATE(ZWL)

ELSE

  ALLOCATE(ZPNMX(KDGNH,IPNMX))
  CALL SUPLIS(KNSMIN,KNSMAX,KDGNH,Z_DLMU(1),.TRUE.,ZPNMX, &
   & Z_DLPNMX,Z_DLAX,Z_DLIX)

  ISE=0
  DO JM=0,KNSMIN
    DO JN=KNSMAX,JM,-1
      ISE=ISE+1
      DO JGL=1,KDGNH
        ZPNMX(JGL,ISE)=ZPNMX(JGL,ISE)*ZW(JGL)
      ENDDO
    ENDDO
  ENDDO

ENDIF

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

!*        3. Computes matrix.
!            ----------------

!         3.1 ZMAPP.

DO JGL=1,KDGNH
  ZMAPP(JGL)=REAL((Z_DLSIN/(1.0_JPRB+Z_DLTAN*Z_DLMU(JGL)))**2,JPKS)
ENDDO
DO JGL=1,KDGNH
  IGLS=2*KDGNH-JGL+1
  ZMAPP(IGLS)=REAL((Z_DLSIN/(1.0_JPRB-Z_DLTAN*Z_DLMU(JGL)))**2,JPKS)
ENDDO

!         3.2 Parallelisation environment for zonal wavenumber distribution.

IF (NPRTRW > 1) THEN

  CALL SUMP_DILB(KNSMIN,KNSMAX,KULOUT, &
   & INASM0,INPROCM,INUMPP,INUMP,INUMPX,IMYMS, &
   & IRDEBL,IRDEBXL,IPNML,IPNMXL)

ENDIF

!         3.3 Transposition for truncation KNSMIN.

IF (NPRTRW > 1) THEN

  ALLOCATE(ZPNM(KDGLG,IPNML))

  ITYP=2
  CALL TRLTOM_DIL(KDGLG,IDGLL,KNSMIN,INUMP,ITYP,&
   & IPNM,IPNML,IRDEB,INPROCM,IMYMS,IGLG,IGLG0,IDGNHL0,&
   & ZPNM_IN,ZPNM)

  DEALLOCATE(ZPNM_IN)

ENDIF

!         3.4 Transposition for truncation KNSMAX.

IF (NPRTRW > 1) THEN

  ALLOCATE(ZPNMX(KDGNH,IPNMXL))

  ITYP=1
  CALL TRLTOM_DIL(KDGNH,IDGNHL,KNSMIN,INUMP,ITYP,&
   & IPNMX,IPNMXL,IRDEBX,INPROCM,IMYMS,IGLG,IGLG0,IDGNHL0,&
   & ZPNMX_IN,ZPNMX)

  DEALLOCATE(ZPNMX_IN)

ENDIF

!         3.5 Open LFI files.

IF ((NPRTRW == 1) .OR. (NPRTRW > 1 .AND. MYSETW == IOPROC)) THEN

  IRP=0
  INARI=0
  INAR=KNSMIN+1
  CALL LFIAFM(IRP,KULDILA,KFACTM)
  CALL LFIOUV(IRP,KULDILA,.TRUE.,'MATDILA','NEW',.TRUE.,LDIMST,&
   & KNIMES,INAR,INARI)  
  CALL LFIAFM(IRP,KULCONT,KFACTM)
  CALL LFIOUV(IRP,KULCONT,.TRUE.,'MATCONT','NEW',.TRUE.,LDIMST,&
   & KNIMES,INAR,INARI)  

  ! Auto-documentation :
  CALL LFIINTECR(IRP,KULDILA,'NSMIN',KNSMIN,1)
  CALL LFIINTECR(IRP,KULDILA,'NSMAX',KNSMAX,1)
  CALL LFIECR(IRP,KULDILA,'RSTRET',PSTRET,1)
  CALL LFIINTECR(IRP,KULCONT,'NSMIN',KNSMIN,1)
  CALL LFIINTECR(IRP,KULCONT,'NSMAX',KNSMAX,1)
  CALL LFIECR(IRP,KULCONT,'RSTRET',PSTRET,1)

ENDIF

!         3.6 Compute dilatation/contraction matrices,
!             send them to the main processor,
!             and write them on LFI files.

!         3.6.1 Case nprtrw=1.

IF (NPRTRW == 1) THEN

  DO JM=0,KNSMIN
    ALLOCATE(ZALPHA(KNSMAX-JM+1,KNSMIN-JM+1))
    ALLOCATE(ZBETA(KNSMAX-JM+1,KNSMIN-JM+1))
    CALL DILAT(JM,KNSMAX,KNSMIN,&
     & KDGNH,ZPNM(1,IRDEB(JM)),ZMAPP,ZPNMX(1,IRDEBX(JM)),&
     & ZALPHA,ZBETA)
    CALL DILATB(JM,KNSMAX,KNSMIN,&
     & KULDILA,KULCONT,KULOUT,ZALPHA,ZBETA)
    DEALLOCATE(ZALPHA)
    DEALLOCATE(ZBETA)
  ENDDO

ENDIF

!         3.6.2 Case nprtrw>1 and mysetw /= ioproc.

! The current processor computes ZALPHA and ZBETA for the DM-local
! zonal wavenumbers 1 to NUMP and sends them to the processor IOPROC.

IF (NPRTRW > 1 .AND. MYSETW /= IOPROC) THEN

  DO JMLOC=1,INUMP
    IMGLO=IMYMS(JMLOC)
    ALLOCATE(ZALPHA(KNSMAX-IMGLO+1,KNSMIN-IMGLO+1))
    ALLOCATE(ZBETA(KNSMAX-IMGLO+1,KNSMIN-IMGLO+1))
    ID1=KNSMAX-IMGLO+1
    ID2=KNSMIN-IMGLO+1
    CALL DILAT(IMGLO,KNSMAX,KNSMIN,&
     & KDGNH,ZPNM(1,IRDEBL(JMLOC)),ZMAPP,ZPNMX(1,IRDEBXL(JMLOC)),&
     & ZALPHA,ZBETA)
    CALL MPL_SEND(ZALPHA(1:ID1,1:ID2),KDEST=IOPROC,&
     & KTAG=ITAG+2*(IMGLO+1),CDSTRING='SUDIL:')
    CALL MPL_SEND(ZBETA(1:ID1,1:ID2),KDEST=IOPROC,&
     & KTAG=ITAG+2*(IMGLO+1)-1,CDSTRING='SUDIL:')
    DEALLOCATE(ZALPHA)
    DEALLOCATE(ZBETA)
    CALL MPL_BARRIER(CDSTRING='SUDIL:')
  ENDDO
  DO JMLOC=INUMP+1,INUMPX
    CALL MPL_BARRIER(CDSTRING='SUDIL:')
  ENDDO

ENDIF

!         3.6.3 Case nprtrw>1 and mysetw=ioproc.

! The current processor computes ZALPHA and ZBETA for the DM-local
! zonal wavenumbers 1 to NUMP and receives the ZALPHA and ZBETA
! computed by the other processors.
! All the ZALPHA and ZBETA are written on LFI files by this processor.

IF (NPRTRW > 1 .AND. MYSETW == IOPROC) THEN

  DO JMLOC=1,INUMP
    IMGLO=IMYMS(JMLOC)
    IIRDEBL(IMGLO)=IRDEBL(JMLOC)
    IIRDEBXL(IMGLO)=IRDEBXL(JMLOC)
  ENDDO

  DO JM=0,KNSMIN

    ALLOCATE(ZALPHA(KNSMAX-JM+1,KNSMIN-JM+1))
    ALLOCATE(ZBETA(KNSMAX-JM+1,KNSMIN-JM+1))
    ID1=KNSMAX-JM+1
    ID2=KNSMIN-JM+1
    IF (INPROCM(JM) == IOPROC) THEN
      CALL DILAT(JM,KNSMAX,KNSMIN,&
       & KDGNH,ZPNM(1,IIRDEBL(JM)),ZMAPP,ZPNMX(1,IIRDEBXL(JM)),&
       & ZALPHA,ZBETA)
    ELSE
      CALL MPL_RECV(ZALPHA(1:ID1,1:ID2),KSOURCE=INPROCM(JM),&
       & KTAG=ITAG+2*(JM+1),CDSTRING='SUDIL:')
      CALL MPL_RECV(ZBETA(1:ID1,1:ID2),KSOURCE=INPROCM(JM),&
       & KTAG=ITAG+2*(JM+1)-1,CDSTRING='SUDIL:')
    ENDIF
    CALL DILATB(JM,KNSMAX,KNSMIN,&
     & KULDILA,KULCONT,KULOUT,ZALPHA,ZBETA)
    DEALLOCATE(ZALPHA)
    DEALLOCATE(ZBETA)
    IF (MOD(JM+1,NPRTRW) == 0) CALL MPL_BARRIER(CDSTRING='SUDIL:')

  ENDDO

  IF(MOD(KNSMIN+1,NPRTRW) /= 0) CALL MPL_BARRIER(CDSTRING='SUDIL:')

ENDIF

!         3.7 Deallocate the PNM arrays.

DEALLOCATE(ZPNM)
DEALLOCATE(ZPNMX)

!         3.8 Close LFI files.

IF ((NPRTRW == 1) .OR. (NPRTRW > 1 .AND. MYSETW == IOPROC)) THEN
  CALL LFIFER(IRP,KULDILA,'KEEP')
  CALL LFIFER(IRP,KULCONT,'KEEP')
ENDIF

CALL MPL_BARRIER(CDSTRING='SUDIL:')

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

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

