SUBROUTINE SUGEM1A(P_DLMU,PW)

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE PARKIND2  ,ONLY : JPRH

USE YOMARG   , ONLY : NULOEN   ,NUMEN    ,NARGS    ,NUHTYP   ,NUSTTYP  ,&
 & USTRET   ,UMUCEN   ,ULOCEN  
USE YOMDIM   , ONLY : NDGLG    ,NDGNH    ,NDGSUR   ,NDGSAG   ,&
 & NDGENG   ,NDLON    ,NSMAX    ,NCMAX    ,NTMAX  
USE YOMGEM   , ONLY : NLOENG   ,NMENG    ,NSTTYP   ,NHTYP    ,&
 & REFLCAPE ,REFLKUO  ,REFLRHC  ,NDGLU ,&
 & RMUCEN   ,RLOCEN   ,RSTRET   ,RNLGINC  
USE YOMCT0   , ONLY : LFPART2  ,NCONF     ,NPRINTLEV,LOUTPUT
USE YOMCT0B  , ONLY : LECMWF
USE YOMLUN   , ONLY : NULOUT   ,NULNAM   ,NULERR
USE YOEPHY   , ONLY : LEPHYS
USE YOMNMIA  , ONLY : LRPIMP   ,LTRANS   ,LNOINI
USE YOMFPG   , ONLY : FPNLGINC

!**** *SUGEM1A*  - Initialize geometry parameters - first part

!     Purpose.
!     --------
!           Initialize geometry

!**   Interface.
!     ----------
!        *CALL* *SUGEM1A

!        Explicit arguments :
!        --------------------
!         P_DLMU:   Gaussian latitudes (out)
!         PW    :   Gaussian weights   (out)

!        Implicit arguments :
!        --------------------
!        See #include below

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

!     Externals.
!     ----------
!                   SUGAWA -  calculate Gaussian latitudes
!                   SURGRI -  read NLOEN on namelist
!                   SUNMEN -  initialize NMENG
!                   Is called by SU0YOMB
!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Mats Hamrud and Philippe Courtier  *ECMWF*

!     Modifications.
!     --------------
!        Original : 87-10-15
!        Modified : 91-07-05 P.Courtier : NDGLU
!        Modified : 92-03-18 P.Courtier : read nloen from namrgri
!        Modified : 92-05-07 J.J. Morcrette: ECMWF physics
!        Modified : 92-07-02 R. Bubnova: RATATH, RATATX
!        Modified : 93-04-02 R. EL Khatib Setup defaults controled by LECMWF
!        Modified : 93-03-19 D. Giard : tests on LTRANS, NCMAX, NTMAX
!        Modified : 93-03-30 R. El Khatib : new computation of NMEN
!        Modified : 93-04-30 D. Giard : computation of R4JP,RC2P1,RC2M1,
!                                       RCOR0,RCOR1,RCOR2
!        Modified by R. El Khatib  :93-05-06 Set-up through command line
!        Modified : 94-02-03 R. El Khatib : Leg. polynomials for I/O 's as
!                                           argument
!        Modified 93-11-15 J.M. Piriou Setup convective truncation threshold
!        Modified by J.M. Piriou:94-01-18 Set-up truncation threshold
!                         for inhibating convection.
!        Modified by R. El Khatib  :94-04-29 NMEN computed in a specific
!                                            subroutine SUNMEN
!        Modified by M. Tolstykh: 94-08-31 Set-up for CUD interpolation
!        Modified by K. YESSAD (MARCH 1995): Extra-latitudes computations
!                 according to value of NDGSUR and LRPOLE only.
!        Modified by MPP Group ECMWF 95-10-01 Distributed Memory version
!        Modified : 95-11-16 Ryad El Khatib (Fullpos LFPART2 without arguments)
!        Modified : 96-02-16 Ryad El Khatib (RNLGINC)
!        Modified 97-04-17 by J.M. Piriou: TEQREF default value.
!        Modified 97-09-09 by K. YESSAD: cleaning for cy18. Correction of
!                 bugs and false comments.
!        Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!          - removal of LRPOLE in YOMCT0 and in 'CALL SUNMEN'.
!          - removal of code under LRPOLE.
!        Modified 98-11-27 by L. Gerard: TEQREF replaced by REFLKUO
!          and REFLCAPE.
!        Modified : 00-03-13 Ryad El Khatib Setup for RNLGINC modified for MF
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        R. El Khatib 05-02-25 Bugfix after the dimension of NUMEN
!        F. Bouyssel 05-03-01 REFLRHC
!        K. Yessad (Sept 2008): Gaussian lat and weights => dummy arg
!        K. Yessad (Sept 2008): Prune conf 951.
!        K.Yessad (Nov 2008): rename arp/SUGAW into arp/SUGAWA.
!     ------------------------------------------------------------------

IMPLICIT NONE

REAL(KIND=JPRH),   INTENT(OUT) :: P_DLMU(NDGLG)
REAL(KIND=JPRB),   INTENT(OUT) :: PW(NDGLG)

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

#include "namgem.h"

!     ------------------------------------------------------------------
!     IFFTP0(J) : 0 ===> possible to use J for the FFT 's
!                 1 ===> not possible
INTEGER(KIND=JPIM) :: IDGLU(0:NSMAX,NDGSAG:NDGNH)
REAL(KIND=JPRB) :: ZMU(NDGLG)
REAL(KIND=JPRB) :: ZSQM2(NDGSAG:NDGENG),ZW(NDGLG),ZNLGINC

INTEGER(KIND=JPIM) ::  J, JGL, JGLSUR, JM,IDNLGINC

LOGICAL :: LLGRID

! -- ky: for call to SUGAWA --------------
INTEGER(KIND=JPIM) :: IDGLG,ISTART,IK,IODD,JN
REAL(KIND=JPRB),ALLOCATABLE :: ZFN(:,:), ZFNLAT(:)
REAL(KIND=JPRB) :: ZFNN
! ----------------------------------------

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "posnam.intfb.h"
#include "sugawa.intfb.h"
#include "sunmen.intfb.h"
#include "surgri.intfb.h"

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

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

!     ------------------------------------------------------------------
!*       1.    Initialize YOMGEM.
!              ------------------

!*    1.1   SET DEFAULT VALUES.

REFLKUO=17558._JPRB
REFLCAPE=89558._JPRB
REFLRHC=150000._JPRB

!        1.1.1 Set implicit default values

IF (NARGS /= 0.OR.LFPART2) THEN
  RMUCEN =UMUCEN
  RLOCEN =ULOCEN
  RSTRET =USTRET
  NSTTYP =NUSTTYP
  NHTYP  =NUHTYP
! We try to guess the value of RNLGINC : 0., 0.1, 0.2, ...,0.5, ... or 1. : 
  IF (ABS(RSTRET-1.0_JPRB)>100.0_JPRB*TINY(1.0_JPRB)) THEN
    ZNLGINC=REAL(NDLON-3-2*NSMAX,JPRB)/REAL(NSMAX,JPRB)
  ELSE
    ZNLGINC=REAL(NDLON-1-2*NSMAX,JPRB)/REAL(NSMAX,JPRB)
  ENDIF
  IDNLGINC=NINT(ZNLGINC*10._JPRB)
  RNLGINC=REAL(IDNLGINC,JPRB)/10._JPRB
ELSE
  RMUCEN =1._JPRB
  RLOCEN =0._JPRB
  RSTRET =1._JPRB
  NSTTYP =1
  NHTYP  =0
  RNLGINC=1._JPRB
ENDIF

!        1.1.2 Modify default values according to LECMWF

IF (LECMWF) THEN
  LLGRID=NSMAX > (NDLON+3)/3
  IF (LLGRID) THEN
    RNLGINC=0._JPRB
  ELSE
    RNLGINC=1._JPRB
  ENDIF
ELSE
  IF ((NCONF == 911).OR.(NCONF == 912)) NHTYP=0
ENDIF

!*    1.2 MODIFY VALUES

!        1.2.1  READ NAMELIST.

CALL POSNAM(NULNAM,'NAMGEM')
READ(NULNAM,NAMGEM)

!        1.2.2  OVERWRITE NAMELIST WITH COMMAND LINE ARGUMENTS
IF (NARGS /= 0.OR.LFPART2) THEN
  IF (RSTRET /= USTRET) THEN
    RSTRET=USTRET
    WRITE(NULERR,*) 'RSTRET  OVERWRITTEN BY COMAND LINE'
  ENDIF
  IF (RMUCEN /= UMUCEN) THEN
    RMUCEN=UMUCEN
    WRITE(NULERR,*) 'RMUCEN  OVERWRITTEN BY COMAND LINE'
  ENDIF
  IF (RLOCEN /= ULOCEN) THEN
    RLOCEN=ULOCEN
    WRITE(NULERR,*) 'RLOCEN  OVERWRITTEN BY COMAND LINE'
  ENDIF
  IF ((NCONF /= 911).AND.(NCONF /= 912)) THEN
    IF (NHTYP /= NUHTYP) THEN
      NHTYP=NUHTYP
      WRITE(NULERR,*) 'NHTYP  OVERWRITTEN BY COMAND LINE'
    ENDIF
  ENDIF
  IF (NSTTYP /= NUSTTYP) THEN
    NSTTYP=NUSTTYP
    WRITE(NULERR,*) 'NSTTYP  OVERWRITTEN BY COMAND LINE'
  ENDIF
ENDIF

!        1.2.3  RESET VARIABLES AND TEST

IF (LEPHYS.AND.NSTTYP /= 1) THEN
  WRITE(NULOUT,FMT='('' ERROR NSTTYP MUST BE 1 IF LEPHYS=.TRUE.'')')
  CALL ABOR1(' SUGEM1A ')
ENDIF

IF (NCONF /= 911.AND.NCONF /= 912.AND.NSTTYP == 1) THEN
  RMUCEN=1._JPRB
  RLOCEN=0._JPRB
ENDIF

IF ((NCONF == 911).OR.(NCONF == 912)) NHTYP=0

IF (LFPART2) THEN
  RNLGINC=FPNLGINC
ENDIF
RNLGINC=MIN(1.0_JPRB,MAX(0.0_JPRB,RNLGINC))

WRITE(NULOUT,FMT='('' NSTTYP = '',I6,&
 & '' RMUCEN = '',E13.7,'' RLOCEN = '',E13.7,&
 & '' RSTRET = '',E13.7)')NSTTYP,RMUCEN,RLOCEN,RSTRET  
WRITE(NULOUT,FMT='('' NHTYP  = '',I6)') NHTYP

!*    1.3   CHECK LOGICAL SWITCHES IN YOMNMIA

! RSTRET < 1. not allowed
IF ((RSTRET-1.0_JPRB) < -1.E-14_JPRB)&
 & CALL ABOR1( ' RSTRET < 1. NOT ALLOWED, CHANGE THE POLE !')  
! No stretching or rotation : normal modes on transformed sphere not allowed
IF (ABS(RSTRET-1.0_JPRB) < 1.E-14_JPRB .OR. NSTTYP /= 1.OR. LRPIMP) THEN
  IF (.NOT.LNOINI .AND. LTRANS)CALL ABOR1(' LTRANS=.T. NOT ALLOWED !')
ENDIF
! Normal modes are to be used in config. 1
IF ((NCONF == 1.OR.NCONF == 302).AND. .NOT.LNOINI) THEN
! No stretching
  IF (ABS(RSTRET-1.0_JPRB) < 1.E-14_JPRB) THEN
    IF (NTMAX /= NSMAX)CALL ABOR1(' IF NO STRETCHING NTMAX=NSMAX !')
    IF (NCMAX /= NSMAX)CALL ABOR1(' IF NO STRETCHING NCMAX=NSMAX !')
  ELSE
! Stretching
    IF (NTMAX > NSMAX+10) CALL ABOR1(' CHECK NTMAX !')
    IF (LTRANS .AND. NTMAX /= NCMAX)&
     & CALL ABOR1(' NNMI ON TRANSF. SPHERE REQUIRES NTMAX=NCMAX !')  
    IF (.NOT.LTRANS.AND.NCMAX < NINT(RSTRET*NSMAX))&
     & WRITE(NULOUT,FMT='('' WARNING : NCMAX < RSTRET*NSMAX !'')')  
  ENDIF
ENDIF

!     ------------------------------------------------------------------
!*       3.    Initialize NLOENG and NMENG.
!              --------------------------

!*    3.1   Preparations

! ky: Calls a version of SUGAW which should be the mirror of the
!     current version of tfl/module/sugaw_mod.F90.
!     We cannot currently call tfl/module/sugaw_mod.F90 here because
!     a subset of the TFL setup must be computed before (work expected
!     to be done for CY37).
!     Not that Gaussian weights and latitudes are re-computed by
!     tfl/module/sugaw_mod.F90 during the TFL set-up calculations.

! * preliminary calculations to compute input quantity ZFNLAT
!   (k.y.: coded after what I found in tfl/module/suleg_mod.F90).
IDGLG=NDGLG
ISTART=1
ALLOCATE(ZFN(0:IDGLG,0:IDGLG))
ALLOCATE(ZFNLAT(0:IDGLG/2))
! Belousov, Swarztrauber use ZFN(0,0)=SQRT(2._JPRB)
! IFS normalisation chosen to be 0.5*Integral(Pnm**2) = 1
ZFN(0,0)=2._JPRB
DO JN=ISTART,IDGLG
  ZFNN=ZFN(0,0)
  DO JGL=1,JN
    ZFNN=ZFNN*SQRT(1._JPRB-0.25_JPRB/REAL(JGL**2,JPRB))
  ENDDO
  IODD=MOD(JN,2)
  ZFN(JN,JN)=ZFNN
  DO JGL=2,JN-IODD,2
    ZFN(JN,JN-JGL)=ZFN(JN,JN-JGL+2) &
     & *REAL((JGL-1)*(2*JN-JGL+2),JPRB)/REAL(JGL*(2*JN-JGL+1),JPRB)
  ENDDO
ENDDO
IODD=MOD(IDGLG,2)
IK=IODD
DO JGL=IODD,IDGLG,2
  ZFNLAT(IK)=ZFN(IDGLG,JGL)
  IK=IK+1
ENDDO

! * call to SUGAWA:
CALL SUGAWA(NDGLG,ZFNLAT,ZSQM2(1),ZMU,ZW)

! * deallocations:
DEALLOCATE(ZFN)
DEALLOCATE(ZFNLAT)

DO JGL = 1, NDGLG
  P_DLMU(JGL)=REAL(ZMU(JGL),JPRH)
ENDDO
PW(1:NDGLG)=ZW(1:NDGLG)

DO JGL = 1, NDGLG
  ZSQM2(JGL)=SQRT(1.0_JPRB-ZMU(JGL)*ZMU(JGL))
ENDDO
IF (NDGSAG <= -1) THEN
!DIR$ IVDEP
!OCL NOVREC
  DO JGLSUR = 1, NDGSUR
    ZSQM2(1-JGLSUR)=ZSQM2(JGLSUR)
  ENDDO
!DIR$ IVDEP
!OCL NOVREC
  DO JGLSUR = 1, NDGSUR
    ZSQM2(NDGLG+JGLSUR)=ZSQM2(NDGLG+1-JGLSUR)
  ENDDO
ENDIF

!*    3.2   Initialize NLOENG, NHTYP = 0
IF (NHTYP == 0) THEN
  DO JGL = NDGSAG, NDGENG
    NLOENG(JGL)=NDLON
  ENDDO

!*    3.3   Initialize NLOENG, NHTYP = 1
ELSEIF (NHTYP == 1) THEN

  CALL ABOR1('SUGEM2 : NHTYP=1 HAS BEEN REMOVED') 

!*    3.4   Initialize NLOENG from namelist namgem1, NHTYP = 2
ELSEIF (NHTYP == 2) THEN
  IF (NARGS /= 0.OR.LFPART2) THEN
    DO J = 1, (NDGLG+1)/2
      NLOENG(J)=NULOEN(J)
    ENDDO
    DO J = (NDGLG+1)/2+1, NDGLG
      NLOENG(J)=NULOEN(NDGLG-J+1)
    ENDDO
    IF (NDGSAG <= 0) THEN
      NLOENG(0)=NLOENG(1)
      NLOENG(NDGLG+1)=NLOENG(NDGLG)
    ENDIF
  ELSE
    CALL SURGRI(NULNAM,NULOUT,NDGLG,NDGSAG,NDGENG,NLOENG)
  ENDIF

  IF (NDGSAG <= -1) THEN
!DIR$ IVDEP
!OCL NOVREC
    DO JGLSUR = 1, NDGSUR
      NLOENG(1-JGLSUR)=NLOENG(JGLSUR)
      NLOENG(NDGLG+JGLSUR)=NLOENG(NDGLG+1-JGLSUR)
    ENDDO
  ENDIF
ELSE
  WRITE(NULOUT,FMT='('' ERROR NHTYP '')')
  CALL ABOR1(' SUGEM1A ')
ENDIF

!*    3.5   initialisation NMEN

WRITE(NULOUT,FMT='('' RNLGINC  = '',E13.7)') RNLGINC

CALL SUNMEN(NSMAX,NHTYP,NDGLG,NLOENG,ZSQM2,NDGSAG,NDGENG,NMENG,RNLGINC)

IF (.NOT.LECMWF .AND. (NARGS /= 0) .AND. .NOT.LFPART2) THEN

! First we control that the value of RNLGINC correspond to what is in file
! if not we overwrite NMENG with the input file values
! but we signal this mismatch by setting RNLGINC=999.
  DO JGL = 1, (NDGLG+1)/2
    IF ( NMENG(JGL) /= NUMEN(JGL) ) THEN
      WRITE(NULOUT,'(''NMENG IN FILE AND RNLGINC IN NAMELIST OR COMMAND'', &
       & '' LINE MISMATCH'')')  
      RNLGINC=999._JPRB
      WRITE(NULOUT,FMT='('' RNLGINC RESET TO '',E13.7)') RNLGINC
      DO J = 1, (NDGLG+1)/2
        NMENG(J)=NUMEN(J)
      ENDDO
      DO J = (NDGLG+1)/2+1, NDGLG
        NMENG(J)=NUMEN(J)
      ENDDO
      IF (NDGSAG <= 0) THEN
        NMENG(0)=NMENG(1)
        NMENG(NDGLG+1)=NMENG(NDGLG)
      ENDIF
      IF (NDGSAG <= -1) THEN
!DIR$ IVDEP
        DO JGLSUR = 1, NDGSUR
          NMENG(1-JGLSUR)=NMENG(JGLSUR)
          NMENG(NDGLG+JGLSUR)=NMENG(NDGLG+1-JGLSUR)
        ENDDO
      ENDIF
      EXIT
    ENDIF
  ENDDO

ENDIF

!*    3.6   Prints NLOENG, NMENG

IF (LOUTPUT.AND.NPRINTLEV >= 1) THEN
  WRITE(NULOUT,FMT='('' (JGL,NLOENG,NMENG) '')')
  WRITE(NULOUT,FMT='(8(1X,''('',I4,I4,I4,'')''))')&
   & (JGL,NLOENG(JGL),NMENG(JGL),JGL=NDGSAG,NDGENG)  
ENDIF

!*       3.7    Initialize NDGLU.

DO JGL=NDGSAG,NDGNH
  DO JM=NMENG(JGL)+1,NSMAX
    IDGLU(JM,JGL)=0
  ENDDO
ENDDO
DO JGL=NDGSAG,NDGNH
  DO JM=0,NMENG(JGL)
    IDGLU(JM,JGL)=1
  ENDDO
ENDDO
DO JM=0,NSMAX
  NDGLU(JM)=0
  DO JGL=1,NDGNH
    NDGLU(JM)=NDGLU(JM)+IDGLU(JM,JGL)
  ENDDO
ENDDO
IF (LOUTPUT.AND.NPRINTLEV >= 1) THEN
  WRITE(NULOUT,FMT='('' (JM,NDGLU) '')')
  WRITE(NULOUT,FMT='(10(1X,''('',I4,I4,'')''))')&
   & (JM,NDGLU(JM),JM=0,NSMAX)  
ENDIF

!!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('SUGEM1A',1,ZHOOK_HANDLE)
END SUBROUTINE SUGEM1A
