SUBROUTINE SUGEM1B

!**** *SUGEM1B*  - Initialize geometry parameters - first part - b

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

!**   Interface.
!     ----------
!        *CALL* *SUGEM1B

!        Explicit arguments :
!        --------------------
!        None

!        Implicit arguments :
!        --------------------
!        COMMON YOMGEM
!        COMMON YOMARG

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

!     Externals.
!     ----------
!        None
!        Is called by SUGEM.

!     Reference
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        MPP Group *ECMWF*

!     Modifications.
!     --------------
!        Original : 95-10-01
!        Modified : 95-11-24 Patrick Le Moigne (default value for TEQREF)
!        Modified : 97-11-14 M. Janiskova (initialization of NMENTC) 
!        Modified : 98-07-22 P. Le Moigne (use NDSUR1 for extra longitudes)
!        Modified 98-08-10 by K. YESSAD: 
!          - removal of LRPOLE option.
!            * removal of LRPOLE in YOMCT0.
!            * removal of code under LRPOLE.
!          - cleanings and optimisations:
!            * use RMU, RSQM2, RC2P1 and RC2M1 to compute RATATH (so part 4
!              is done before computation of RATATH), removal of useless
!              call to SUGAW.
!            * for SM, simplification of the computation of the extrapolar
!              values of RATATH and RATATX, since these values do not depend
!              on computational sphere longitude.
!            * use only NDGLG or NDGLL, but not NDGL.
!            * use only NDGSAG or NDGSAL, but not NDGSA.
!            * use only NDGENG or NDGENL, but not NDGEN.
!        Modified: 98-08-11 L. Gerard (replacement TEQREF and TEQA by
!                                      REFLKUO, TEQK, REFLCAPE, TEQC)
!        Modified: 99-01-04 J.M. Piriou (initialize TEQK and TEQC from NDLON).
!        Modified 99-02-17 by K. YESSAD: options LRETCFOU, LWRTCFOU.
!        Modified 02-10-23 by K. YESSAD: make possible the use of
!         NTCMAX=NDLON/2.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        Modified: 05-03-01 F. Bouyssel (REFLRHC, TEQH).
!     ------------------------------------------------------------------

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

USE YOMCST   , ONLY : RPI      ,RA
USE YOMDIM   , ONLY : NDGLG    ,NDGLL    ,NDGSAL   ,NDGENL   ,NTCMAX   ,NDLON
USE YOMGEM   , ONLY : RATATH   ,RATATX   ,NLOEN    ,NLOENG   ,&
 & NMEN     ,NMENTC   ,NMENG    ,NSTAGP   ,NGPTOT   ,RMUCEN   ,RSTRET   ,&
 & R4JP     ,RC2P1    ,RC2M1    ,RCOR0    ,RCOR1    ,&
 & RCOR2    ,REFLCAPE ,REFLKUO  ,REFLRHC  ,TEQC     ,TEQK     ,TEQH
USE YOMCT0   , ONLY : NCONF    ,NPRINTLEV,&
 & LOUTPUT  ,LALLOPR  ,LRETCFOU ,LWRTCFOU   
USE YOMLUN   , ONLY : NULOUT
USE YOMMP    , ONLY : MY_REGION_EW   ,MYSETW   ,NPTRLS   ,NSTA     ,&
 & NONL     ,MYLATS   ,NPTRFLOFF  
USE YOMLEG   , ONLY : RMU      ,RSQM2

IMPLICIT NONE

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

INTEGER(KIND=JPIM) :: IENDL, IENDLAT, IGL, IGLGLO,&
 & IROF, ISTAL, ISTALAT, IU, JGL, JGLLOC, JLON, JGLGLO  

LOGICAL :: LLP

REAL(KIND=JPRB) :: ZC, ZX
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!*       1.    Return when init. of rotation and stretching matrices.
!              ------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SUGEM1B',0,ZHOOK_HANDLE)
IF (NCONF == 911.OR.NCONF == 912 .AND. LHOOK) CALL DR_HOOK('SUGEM1B',1,ZHOOK_HANDLE)
IF (NCONF == 911.OR.NCONF == 912) RETURN

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

!*       2.    Initialize NLOEN, NMEN, NMENTC.
!              -------------------------------

ISTAL=1
IENDL=NDGLL

! * Compute NMEN and NLOEN:
DO JGL=ISTAL,IENDL
  IGLGLO = NPTRLS(MYSETW)+JGL-1
  NMEN(JGL) = NMENG(IGLGLO)
  NLOEN(JGL) = NLOENG(IGLGLO)
ENDDO

! * Compute NMENTC:
IF (LRETCFOU.OR.LWRTCFOU) THEN

  ! * Case NTCMAX=NDLON/2:
  IF (NTCMAX == NDLON/2) NMENTC(1:NDGLG)=NLOENG(1:NDGLG)/2

  ! * Other cases: one always assumes that:
  !   - NTCMAX <= NSMAX in spherical geometry.
  !   - NTCMAX <= NMSMAX in plane geometry.
  IF (.NOT.(NTCMAX == NDLON/2)) THEN
    DO JGLGLO=1,NDGLG
      NMENTC(JGLGLO)=MIN(NMENG(JGLGLO),NTCMAX)
    ENDDO
  ENDIF

ENDIF

! * Print NLOEN, NMEN, NMENTC.
IF (LOUTPUT.AND.NPRINTLEV >= 1) THEN

  WRITE(UNIT=NULOUT,FMT='('' (JGL,NLOEN,NMEN) '')')
  WRITE(UNIT=NULOUT,FMT='(8(1X,''('',I4,I4,I4,'')''))')&
   & (JGL,NLOEN(JGL),NMEN(JGL),JGL=ISTAL,IENDL)  
  IF (LRETCFOU.OR.LWRTCFOU) THEN
    WRITE(UNIT=NULOUT,FMT='('' (-- print DM-global array NMENTC --) '')')
    WRITE(UNIT=NULOUT,FMT='('' (JGLGLO,NMENTC) '')')
    WRITE(UNIT=NULOUT,FMT='(8(1X,''('',I4,I4,'')''))')&
     & (JGLGLO,NMENTC(JGLGLO),JGLGLO=1,NDGLG)  
  ENDIF
ENDIF

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

!*       4.     Initialize constants
!                --------------------

R4JP=(4._JPRB*REAL(NDGLG,JPRB)+2)/(4._JPRB*RPI)
ZC=RSTRET
RC2P1=ZC*ZC+1.0_JPRB
RC2M1=ZC*ZC-1.0_JPRB
! f/(2*omega) = sin(latP) *(a*mu+b)/(a+b*mu)
!             + cos(latP) *cos(lon) *sqrt(1-mu*mu)/(a+b*mu)
!             # RCOR0 +RCOR1*sqrt(3)*mu +RCOR2*sqrt(3/2)*sqrt(1-mu*mu)*2cos(lon)
! if c > 1. :
! RCOR0/sin(latP)= a/b + (1-(a/b)**2)*ln(sqrt((a+b)/(a-b)))
! RCOR1/sin(latP)= sqrt(3)* (1-(a/b)**2) * (1-(a/b)*ln(sqrt((a+b)/(a-b))) )
! RCOR2/cos(latP)= sqrt(3/2)/2b * (a/b+(1-(a/b)**2)*ln(sqrt((a+b)/(a-b)))
! if c = 1. :
! RCOR0= 0
! RCOR1= sin(latP)/sqrt(3)
! RCOR2= cos(latP)/sqrt(3/2)/2
! a=(c+1/c)/2 ; b=(c-1/c)/2 ; latP = latitude of the pole on the real sphere
IF (ABS(RSTRET-1.0_JPRB) < 1.E-14_JPRB) THEN
  RCOR0=0._JPRB
  RCOR1=RMUCEN/SQRT(3._JPRB)
  RCOR2=SQRT(1.0_JPRB-RMUCEN*RMUCEN)/SQRT(3._JPRB/2.0_JPRB)/2.0_JPRB
ELSE
  ZX=RC2P1/RC2M1
  RCOR0=RMUCEN*(ZX+(1.0_JPRB-ZX*ZX)*LOG(ZC))
  RCOR1=RMUCEN*SQRT(3._JPRB)*(1.0_JPRB-ZX*ZX)*(1.0_JPRB-ZX*LOG(ZC))
  RCOR2=SQRT(1.0_JPRB-RMUCEN*RMUCEN)*ZC*SQRT(3._JPRB/2.0_JPRB)/RC2M1 &
   & *(ZX+(1.0_JPRB-ZX*ZX)*LOG(ZC))  
ENDIF
WRITE(UNIT=NULOUT,FMT='('' CORIOLIS EXPANSION : (N,M)= '',&
 & ''(0,0) : '',E13.7,''  (1,0) : '',E13.7,''  (1,1) : '',E13.7)')&
 & RCOR0,RCOR1,RCOR2  

!     Constant TEQC, TEQK, TEQH used as a threshold in the physics for
!     inhibating convection.
!     WARNING: THIS EXPRESSION OF TEQC, TEQK, TEQH  IS INITIALIZED IN THE
!     PRESENT ROUTINE FOR ARPEGE-IFS AND IN SUEBIG FOR ALADIN.
!     IN CASE OF MODIFICATION YOU HAVE TO CONTROL CONSISTENCY
!     BETWEEN THE TWO EXPRESSIONS.
TEQK=REFLKUO*NDLON/(2.0_JPRB*RPI*RA)
TEQC=REFLCAPE*NDLON/(2.0_JPRB*RPI*RA)
TEQH=REFLRHC*NDLON/(2.0_JPRB*RPI*RA)

WRITE(UNIT=NULOUT,FMT='(4(A,E16.7))')&
 & ' REFLKUO= ',REFLKUO,' TEQK= ',TEQK,&
 & ' REFLCAPE= ',REFLCAPE,' TEQC= ',TEQC,&
 & ' REFLRHC= ',REFLRHC,' TEQH= ',TEQH  

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

!*       5.     Compute NSTAGP
!               --------------

ISTALAT=NDGSAL
IENDLAT=NDGENL

LLP = NPRINTLEV >= 1.OR. LALLOPR
IU = NULOUT
ALLOCATE(NSTAGP(ISTALAT:IENDLAT))
IF(LLP)WRITE(IU,9) 'NSTAGP   ',SIZE(NSTAGP ),SHAPE(NSTAGP )

IROF=1
DO JGL=ISTALAT,IENDLAT
  IF (NONL(NPTRFLOFF+JGL,MY_REGION_EW) > 0) THEN
    NSTAGP(JGL)=IROF
    IROF=IROF+NONL(NPTRFLOFF+JGL,MY_REGION_EW)
  ELSE
    NSTAGP(JGL)=0
  ENDIF
ENDDO

IF (LOUTPUT.AND.NPRINTLEV >= 1) THEN
  WRITE(UNIT=NULOUT,FMT='('' NSTAGP'')')
  WRITE(UNIT=NULOUT,FMT='(16(1X,I6))')(NSTAGP(JGL),JGL=ISTALAT,IENDLAT)
ENDIF

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

!*       6.     Compute the curvature terms RATATH and RATATX.
!               ----------------------------------------------

!*       6.1    allocation of RATATH and RATATX.

ALLOCATE(RATATH (NGPTOT))
IF(LLP)WRITE(IU,9) 'RATATH   ',SIZE(RATATH   ),SHAPE(RATATH   )
ALLOCATE(RATATX (NGPTOT))
IF(LLP)WRITE(IU,9) 'RATATX   ',SIZE(RATATX   ),SHAPE(RATATX   )
9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

!*       6.2    computation of RATATH and RATATX for non extrapolar latitudes.

ISTALAT=NDGSAL
IENDLAT=NDGENL

IROF=0
DO JGLLOC = ISTALAT,IENDLAT
  IGL=MYLATS(JGLLOC)
  IROF=NSTAGP(JGLLOC)-1
  DO JLON = NSTA(NPTRFLOFF+JGLLOC,MY_REGION_EW),&
     & NSTA(NPTRFLOFF+JGLLOC,MY_REGION_EW)+&
     & NONL(NPTRFLOFF+JGLLOC,MY_REGION_EW)-1  
    IROF=IROF+1
    RATATH(IROF)=(RC2M1+RMU(IGL)*RC2P1)/(RSTRET*RA*RSQM2(IGL))
    RATATX(IROF) = 0.0_JPRB
  ENDDO
ENDDO

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

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