PROGRAM SURGRI

! Purpose :
! -------
!   A calling program to make a gaussian reduced grid from several parameters

! Interface :
! ---------
!   None

! Externals :
! ---------
!   REDUCED_GRID  - to compute the reduced grid

! Method :
! ------

!   Read a namelist or command-line arguments ?

! Reference :
! ---------

! Author :
! ------
!   12-Feb-2007 R. El Khatib  *METEO-FRANCE*

! Modifications :
! -------------
!   08-Nov 2007 R. El Khatib : Fix arguments to get_opt

! End Modifications
!-----------------------------------------------------------------------------

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


IMPLICIT NONE


INTEGER(KIND=JPIM) :: IULOUT, IULERR ! stdout, stderr unit numbers
INTEGER(KIND=JPIM) :: IDGLG ! number of latidudes
INTEGER(KIND=JPIM) :: IDLON ! number of longitudes
INTEGER(KIND=JPIM) :: ISMAXG ! truncation
INTEGER(KIND=JPIM) :: IALIAS ! absolute value of aliasing exponent

INTEGER(KIND=JPIM)  :: IOPTVAL, GET_OPT
CHARACTER(LEN=16) :: CLOPTP='o:e:a:t:l:g:'
CHARACTER(LEN=40) :: CLARG
CHARACTER(LEN=1)  :: CLOPT
CHARACTER(LEN=256),SAVE :: CLENV

LOGICAL :: LLMPOFF

REAL(KIND=JPRB) :: ZALIAS
INTEGER(KIND=JPIM), ALLOCATABLE  :: ILOENG(:) ! (output)

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

IULOUT=6
IULERR=0
IDGLG=32
IDLON=64
ISMAXG=21
IALIAS=4

CALL EC_GETENV('DR_HOOK_NOT_MPI',CLENV)
IF (CLENV == ' ' .OR. CLENV == '0' .OR. &
 & CLENV == 'false' .OR. CLENV == 'FALSE') THEN
  LLMPOFF=.FALSE.
  CALL MPL_INIT(LDINFO=.FALSE.) ! Do not produce any output
ELSE
  LLMPOFF=.TRUE.
ENDIF

IOPTVAL=GET_OPT(CLOPTP,CLARG,LLMPOFF)
DO WHILE(IOPTVAL > 0)
  CLOPT=CHAR(IOPTVAL)
  IF (CLOPT == 'o') THEN
!   -o logical unit number of output file
    READ(UNIT=CLARG,FMT='(I2)') IULOUT
  ELSEIF (CLOPT == 'e') THEN
!   -e logical unit number of error file
    READ(UNIT=CLARG,FMT='(I2)') IULERR
  ELSEIF (CLOPT == 'a') THEN
!   -a absolute value of aliasing exponent
    READ(UNIT=CLARG,FMT='(I2)') IALIAS
  ELSEIF (CLOPT == 't') THEN
!   -t truncation
    READ(UNIT=CLARG,FMT='(I4)') ISMAXG
  ELSEIF (CLOPT == 'l') THEN
!   -l number of longitudes
    READ(UNIT=CLARG,FMT='(I4)') IDLON
  ELSEIF (CLOPT == 'g') THEN
!   -g number of Gaussian latitudes
    READ(UNIT=CLARG,FMT='(I4)') IDGLG
  ELSE
    PRINT*, ' USAGE:'
    PRINT*, ' -t truncation [',ISMAXG,']'
    PRINT*, ' -l number of longitudes',IDLON,']'
    PRINT*, ' -g number of Gaussian latitudes',IDGLG,']'
    PRINT*, ' -a absolute value of aliasing exponent',IALIAS,']'
    PRINT*, ' -e logical unit number of error file',IULERR,']'
    PRINT*, ' -o logical unit number of output file',IULOUT,']'
    CALL ABOR1('SURGRI : ERROR IN COMMAND LINE ARGUMENTS')
  ENDIF
  IOPTVAL=GET_OPT(CLOPTP,CLARG,LLMPOFF)
ENDDO

ZALIAS=-REAL(IALIAS,KIND=JPRB)
ALLOCATE(ILOENG(IDGLG))
CALL REDUCED_GRID(IULOUT,IULERR,IDGLG,IDLON,ISMAXG,ZALIAS,ILOENG)
DEALLOCATE(ILOENG)
IF (.NOT.LLMPOFF) CALL MPL_END
IF (LHOOK) CALL DR_HOOK('SURGRI',1,ZHOOK_HANDLE)
STOP

CONTAINS

SUBROUTINE REDUCED_GRID(KULOUT,KULERR,KDGLG,KDLON,KSMAXG,PALIAS,KLOENG)

! Purpose :
! -------
!   *REDUCED_GRID* Compute a global reduced grid, from a given truncation and
!   maximum aliasing rate.

! Interface :
! ---------
!   KULOUT : standard output unit number
!   KULERR : standard error unit number
!   KDGLG  : total number of latitude
!   KDLON  : maximum number of longitude
!   KSMAXG : spectral truncation
!   PALIAS : maximum allowed aliasing rate (exponent)
!   KLOENG : number of longitudes for each latitude

! Externals :
! ---------
!   SETUP_TRANS0 - basic initialization
!   SETUP_TRANS  - resolution dependent initialization

! Method :
! ------

! Use the spectral transform package to compute the Legendre polynomials at
! twice the given truncation.
! Check orthogonality of polynomials up to IOMAX with those within INMAX
! IOMAX=I2SMAX ==> quadratic grid if I2SMAX=INMAX*1.5 (oversized I2SMAX)
! IOMAX=INMAX ==> linear grid

! Not Program not ready for MPI ... but is it worth ?

! IMPORTANT NOTICE : the Legendre polynomials should be computed in quadruple
! precisionn for enough accuracy.

! Reference :
! ---------
!   After an article and program by Philippe Courtier  *ECMWF/METEO-FRANCE*

! Author :
! ------
!   12-Feb-2007 R. El Khatib  *METEO-FRANCE*

! Modifications :
! -------------

! End Modifications
!-----------------------------------------------------------------------------

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


IMPLICIT NONE


INTEGER(KIND=JPIM), INTENT(IN)  :: KULOUT, KULERR, KDGLG, KSMAXG, KDLON
REAL(KIND=JPRB),    INTENT(IN)  :: PALIAS
INTEGER(KIND=JPIM), INTENT(OUT) :: KLOENG(KDGLG)

INTEGER(KIND=JPIM) :: I2SMAX, IOMAX, INMAX, IDGNH
INTEGER(KIND=JPIM) :: JOR, JM, JN1, JN2, JGL, J, I, II

REAL(KIND=JPRB) :: ZMAX, ZEPS
REAL(KIND=JPRB) :: ZGW(KDGLG) ! Gaussian weights

REAL(KIND=JPRB), ALLOCATABLE :: ZPNM(:,:)  ! Legendre polynomials
REAL(KIND=JPRB), ALLOCATABLE :: Z_ONE(:,:) ! unity-matrix
REAL(KIND=JPRB), ALLOCATABLE :: ZORTH(:,:)
REAL(KIND=JPRB), ALLOCATABLE :: ZQ(:,:)
REAL(KIND=JPRB), ALLOCATABLE :: ZGR(:,:,:)

INTEGER(KIND=JPIM) :: IFFTP0(KDLON)
INTEGER(KIND=JPIM), ALLOCATABLE :: IPMS(:) ! Adress in polynomials for given M
INTEGER(KIND=JPIM), ALLOCATABLE :: IADD(:)

INTEGER(KIND=JPIM) :: ILEI3    ! First dimension of Legendre polynomials
INTEGER(KIND=JPIM) :: ISPOLEG  ! Second dimension of Legendre polynomials

LOGICAL :: LLT=.TRUE.

REAL(KIND=JPRB) :: ZHOOK_HANDLE


INTERFACE
#include "setup_trans0.h"
#include "setup_trans.h"
#include "trans_inq.h"
END INTERFACE

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

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


#ifndef REALHUGE
CALL ABOR1('SURGRI : NEEDS QUADRUPLE PRECISION')
#endif

! 1. Setup
!    -----

IF (KSMAXG > (KDLON+3)/3) THEN
! Linear grid
  I2SMAX=2*(KDLON-1)/3
ELSE
  I2SMAX=2*KSMAXG
ENDIF
INMAX=MIN((KDLON-1)/3,I2SMAX)
IDGNH=(KDGLG+1)/2

ZEPS=EPSILON(1._JPRB)*10._JPRB

! 2. Compute Legendre polynomials
!    ----------------------------
CALL SETUP_TRANS0(KOUT=KULOUT,KERR=KULERR,LDMPOFF=LLT)
CALL SETUP_TRANS(KSMAX=I2SMAX,KDGL=KDGLG)  
CALL TRANS_INQ(KLEI3=ILEI3,KSPOLEGL=ISPOLEG)

ALLOCATE(ZPNM(ILEI3,ISPOLEG),IPMS(0:I2SMAX))

CALL TRANS_INQ(PGW=ZGW,PRPNM=ZPNM,KPMS=IPMS)
CALL TRANS_END

! 3. Control the polynomials orthogonality
!    -------------------------------------

ALLOCATE(ZGR(0:INMAX,IDGNH,2))
ALLOCATE(Z_ONE(0:I2SMAX,0:I2SMAX))

Z_ONE(:,:)=0._JPRB
DO JM=0,I2SMAX
  Z_ONE(JM,JM)=1._JPRB
ENDDO


I=INMAX+MOD(INMAX+1,2)
ALLOCATE(IADD(0:I))
DO JM=0,INMAX
  IADD(JM)=IPMS(JM)+I2SMAX+2
ENDDO

I=MAX(I2SMAX,INMAX)+MOD(MAX(I2SMAX,INMAX)+1,2)
II=INMAX+MOD(INMAX+1,2)
ALLOCATE(ZORTH(0:I,0:INMAX))
ALLOCATE(ZQ(0:I,0:INMAX))

DO JOR=1,2
  IF (JOR == 1) THEN
    IOMAX=I2SMAX
  ELSE
    IOMAX=INMAX
  ENDIF
  DO JM=0,INMAX
    DO JN1=JM,INMAX
      DO JN2=JM,IOMAX
        ZORTH(JN2,JN1)=0._JPRB
      ENDDO
    ENDDO
    DO JN1=JM,INMAX
      DO JN2=JM,IOMAX
        ZQ(JN2,JN1)=REAL(1+(-1)**MOD(JN1-JM,2)*(-1)**MOD(JN2-JM,2))
      ENDDO
    ENDDO
    DO JGL=IDGNH,1,-1
      DO JN1=JM,INMAX
        DO JN2=JM,IOMAX
          ZORTH(JN2,JN1)=ZORTH(JN2,JN1)+                                     &
           & ZPNM(JGL,IADD(JM)-JN1)*ZPNM(JGL,IADD(JM)-JN2) &
           & *ZQ(JN2,JN1)*ZGW(JGL)
        ENDDO
      ENDDO
      ZMAX=-1._JPRB
      DO JN1=JM,INMAX
        DO JN2=JM,IOMAX
          ZMAX=MAX(ZMAX,ABS(ZORTH(JN2,JN1)-Z_ONE(JN2,JN1)))
        ENDDO
      ENDDO
      ZGR(JM,JGL,JOR)=ZMAX
    ENDDO
  ENDDO
ENDDO
DEALLOCATE(ZORTH)
DEALLOCATE(ZQ)

DEALLOCATE(ZPNM)
DEALLOCATE(Z_ONE)

DO JOR=1,2
  DO JGL=IDGNH,1,-1
    DO JM=0,INMAX
      ZGR(JM,JGL,JOR)=LOG10(MAX(ZEPS,ZGR(JM,JGL,JOR)))
    ENDDO
  ENDDO
ENDDO

DEALLOCATE(IADD)


! 4. Compute the reduced grid
!    ------------------------

CALL SUFFTP(KDLON,IFFTP0)
KLOENG(:)=0
DO JGL=1,IDGNH
! linear grid :
  DO JM=INMAX,0,-1
    IF ((ZGR(JM,MIN(IDGNH,JGL+1),2)) >= -12._JPRB) THEN
      KLOENG(JGL)=2*MIN(JM+1,INMAX)+1
      EXIT
    ENDIF
  ENDDO
! quadratic grid :
  DO JM=INMAX,0,-1
    IF ((ZGR(JM,MIN(IDGNH,JGL+1),1)) >= PALIAS) THEN
      KLOENG(JGL)=MAX(KLOENG(JGL),3*MIN(JM+1,INMAX)+1)
      EXIT
    ENDIF
  ENDDO
! fft compatibility :
  DO J=KLOENG(JGL),KDLON
    IF (IFFTP0(J) == 0)THEN
      KLOENG(JGL)=J
      EXIT
    ENDIF
  ENDDO
ENDDO

DEALLOCATE(ZGR)

DO J=1,KDGLG/2
  KLOENG(KDGLG+1-J)=KLOENG(J)
ENDDO

! 5. Print out resulting grid
!    ------------------------

WRITE(KULOUT,FMT='('' REDUCED GRID FROM NSMAX = '', I4, '' NDLON = '', I4, &
 & '' NDGL = '',I4,'' ALIASING BEYOND 1.E'',I3.2,'' INMAX = '',I4)')       &
 & KSMAXG,KDLON,KDGLG,INT(PALIAS),INMAX
IF (KDLON.LE.99) THEN
  DO JGL=1,(KDGLG+1)/2
    WRITE(KULOUT,FMT='(''   NRGRI('',I2,'')='',I2,'','')') JGL,KLOENG(JGL)
  ENDDO
ELSEIF (KDLON.LE.999) THEN
  DO JGL=1,(KDGLG+1)/2
    WRITE(KULOUT,FMT='(''   NRGRI('',I3,'')='',I3,'','')') JGL,KLOENG(JGL)
  ENDDO
ELSEIF (KDLON.LE.9999) THEN 
  DO JGL=1,(KDGLG+1)/2
    WRITE(KULOUT,FMT='(''   NRGRI('',I4,'')='',I4,'','')') JGL,KLOENG(JGL)
  ENDDO
ELSE
  DO JGL=1,(KDGLG+1)/2
    WRITE(KULOUT,FMT='(''   NRGRI('',I4,'')='',I5,'','')') JGL,KLOENG(JGL)
  ENDDO
ENDIF

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

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

END PROGRAM SURGRI
