/***************************** LICENSE START ***********************************

 Copyright 2012 ECMWF and INPE. This software is distributed under the terms
 of the Apache License version 2.0. In applying this license, ECMWF does not
 waive the privileges and immunities granted to it by virtue of its status as
 an Intergovernmental Organization or submit itself to any jurisdiction.

 ***************************** LICENSE END *************************************/

//-- This file contains the new C++ code for old Fortran functions,
//-- from obsolete files velstr.F, dvvalid.F, and bppsmth.F. The old
//-- Fortran code has been left here for possible verifications. (090820/vk)

#include <math.h>
#include "Velstr.h"
#include "grib_api.h"

#if 0
      SUBROUTINE VELSTR
C
C          COMPUTE STREAM FUNCTION IF VORTICITY SUPPLIED
C          COMPUTE VELOCITY POTENTIAL IF DIVERGENCE SUPPLIED
C
C        Input:
C          Fieldset of vorticity or divergence (spherical harmonics)
C          Spectral truncation required
C          Indicator for whether spatial smoothing required
C          Smoothing constants
C
C        Output:
C          Fieldset of stream function or velocity potential
C           (spherical harmonics)
C
C        Author:
C          B. Norris,  November 1994
C
#include <grbsh.h>
#include <grbsec.h>
C
      integer cputenv

#ifdef __alpha
      INTEGER*8 IGRIB1,ICNT,IGRIB2,JMGRIBB,IWORD
#endif

      DIMENSION IGRIB(JMGRIB)
      DIMENSION ISEC0(JSEC0)
      DIMENSION ISEC1(JSEC1)
      DIMENSION ISEC2(JSEC2)
      DIMENSION ISEC3(JSEC3)
      DIMENSION ISEC4(JSEC4)
      DIMENSION ZSEC2(JPSEC2)
      DIMENSION ZSEC3(JPSEC3)
      DIMENSION RD(JMUAF)
      LOGICAL NLSMTH, NLSCAL
      CHARACTER*4 YSMTH
      INTEGER	IERROR		!AUXILIARY VARIABLE

c
c -------------------------------------------------------------------
c
C     GET FIRST ARGUMENT AS A FIELDSET OF VORTICITY OR DIVERGENCE.
C               ICNT IS THE NUMBER OF FIELDS

      CALL MGETG(IGRIB1,ICNT)

C        GET USER OPTIONS
C
C           Spectral truncation
      CALL MGETN (RTOUT)

C           Smoothing and scaling indicators and constants
      CALL MGETS (YSMTH)
      NLSMTH=.FALSE.
      IF(YSMTH(1:1).EQ.'y'.OR.YSMTH(1:1).EQ.'Y') NLSMTH=.TRUE.

      CALL MGETS (YSMTH)
      NLSCAL=.FALSE.
      IF(YSMTH(1:1).EQ.'y'.OR.YSMTH(1:1).EQ.'Y') NLSCAL=.TRUE.

      CALL MGETN (FLTC)
      CALL MGETN (RFLTEXP)
      MFLTEXP = NINT (RFLTEXP)

C     CREATE A NEW FIELDSET

      CALL MNEWG(IGRIB2)
C
c -------------------------------------------------------------------
c
C     LOOP ON FIELDS

      DO 10 I=1,ICNT

C       GET NEXT FIELD FROM FIELDSET

	JMGRIBB = JMGRIB	!POINTERS BETWEEN C AND FORTRAN MUST BE 8 BYTES
        CALL MLOADG(IGRIB1,IGRIB,JMGRIBB)
        IPNTS = JMUAF
        IERR = 0
        CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,
     C             RD,IPNTS,IGRIB,JMGRIB,IWORD,'D',IERR)

C           VALIDATE

        CALL DVVALID (ISEC1,ISEC2,IERROR)
	IF(IERROR.NE.0) RETURN

C           COMPUTE VELOCITY POTENTIAL OR STREAM FUNCTION

        ITIN = ISEC2(2)
        NTOUT = NINT (RTOUT)
        IF (NTOUT.GT.ITIN) THEN
C	 CALL PUTENV
	 JJ=cputenv
     +   ('VELSTR_ENV=OUTPUT TRUNCATION GREATER THAN INPUT TRUNCATION')
	 RETURN
	ENDIF
        IF (NTOUT.EQ.0) NTOUT=ITIN
        IF(ISEC1(6).EQ.138) THEN
C             IF(I.EQ.1) CALL MSETS ('str')
Cvk          NFIELDR=215
C            -- WMO Table 2 version 1: 35=Stream function --
             NFIELDR=35
        ELSE
C             IF(I.EQ.1) CALL MSETS ('vel')
Cvk          NFIELDR=214
C            -- WMO Table 2 version 1: 36=Velocity potential --
             NFIELDR=36
        ENDIF
        CALL DVTOVS (RD,JMUAF,ITIN,NTOUT)

C           SMOOTHING

        ITIN = NTOUT
        NPREL4 = ITIN+1
        I1 = JMUAF
        IF(NLSMTH) CALL BPPSMTH (RD,I1,FLTC,MFLTEXP,NPREL4)

C          SCALE AND REPACK DERIVED FIELD
C       streamfunction should not be scaled => new param (030331/vk)

        IF( NLSCAL ) THEN
           PRINT*,' Scale the result!!!'
           IPNTS = (NTOUT+1)*(NTOUT+2)
           DO 152 KD=1,IPNTS
              RD(KD)=RD(KD)*0.000001
  152      CONTINUE
        ELSE
           PRINT*,' _NO_ scaling of the result!!!'
        END IF
Cvk     -- use parameter numbers from WMO GRIB Table 2 version 1  --
Cvk     -- use this old table as Magics does not yet have 2 nor 3 --
        ISEC1(1) = 1
        ISEC1(6) = NFIELDR

        ISEC2(2) = NTOUT
        ISEC2(3) = NTOUT
        ISEC2(4) = NTOUT
C        IF(ISEC2(6).EQ.2) CALL GRSMKP (1)
C           FORCE SIMPLE PACKING
        ISEC2(6) = 1
        ISEC4(1) = IPNTS
        DO 162 K4=3,JSEC4
           ISEC4(K4) = 0
  162   CONTINUE

        IF(I.EQ.1) THEN
             CALL GRPRS0 (ISEC0)
             CALL GRPRS1 (ISEC0,ISEC1)
             CALL GRPRS2 (ISEC0,ISEC2,ZSEC2)
             CALL GRPRS3 (ISEC0,ISEC3,ZSEC3)
             CALL GRPRS4 (ISEC0,ISEC4,RD)
        ENDIF

        RMIN=1.0E10
        RMAX=-1.0E10
        DO 202 KD=1,IPNTS
        IF(RD(KD).LT.RMIN) RMIN=RD(KD)
        IF(RD(KD).GT.RMAX) RMAX=RD(KD)
  202   CONTINUE
        WRITE (*,*) ' RMIN ',RMIN,' RMAX ',RMAX

        IERR = 0
        CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,
     C             RD,IPNTS,IGRIB,JMGRIB,IWORD,'C',IERR)

C          ADD TO FIELDSET

        CALL MSAVEG(IGRIB2,IGRIB,IWORD)

10    CONTINUE

c --------------------------------------------------------------------

C     SET RESULT
      CALL MSETG(IGRIB2)

      RETURN
      END
#endif

//CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
//_____________________________________________________________________________
#if 0
      SUBROUTINE DVTOVS(P,K1,KTIN,KTOUT)
C
C     CALCULATE THE SPERICAL HARMONIC COEFFICIENTS OF VELOCITY
C     POTENTIAL OR STREAM FUNCTION GIVEN THE COEFICIENTS OF
C     DIVERGENCE OR VORTICITY, RESPECTIVELY
C
C    INPUT :
C     P     : SPECTRAL FIELD
C     K1    : LENGTH OF ARRAY P
C     KTIN  : TRUNCATE INPUT (ORIGINAL) VALUE
C     KTOUT : TRUNCATE OUTPUT VALUE
C
C    OUTPUT :
C     P     : SPECTRAL FIELD OVER USER SELECTED AREA
C     KTIN  : TRUNCATE INPUT (VALUE EQUAL KTOUT)
C
C
      INTEGER     K1,KTIN,KTOUT
      DIMENSION P(K1)

      PARAMETER (JMTRUNC=213)
      PARAMETER (JMUAF=(JMTRUNC+1)*(JMTRUNC+2))
      DIMENSION  DUMMY(JMUAF)

      REARTH=6.371E6
      REARTHS = -REARTH*REARTH
      ITINP1  = KTIN  + 1
      ITOUTP1 = KTOUT + 1

      DUMMY(1) = 0.
      DO 1 N=2,ITINP1
         DUMMY(N) = REARTHS/FLOAT((N-1)*N)
 1    CONTINUE

      I  = 1
      II = 1
      DO 2 M=1,ITOUTP1
         DO 20 N=M,ITOUTP1
            P(II  ) = DUMMY(N)*P(I  )
            P(II+1) = DUMMY(N)*P(I+1)
              I     = I  + 2
              II    = II + 2
 20      CONTINUE
         I = I + (ITINP1 - ITOUTP1)*2
 2    CONTINUE
      KTIN=KTOUT

      RETURN
      END
#endif

void
Velstr::convert_DVTOVS( grib_handle* gh, int trunc_out )
{
  const double earth  = 6.371e6;
  const double earths = -earth*earth;

  size_t len = 0;                              //-- data values count
  int ret = grib_get_size( gh, "values", &len );
  badRetVal( ret, "grib_get_size", "Velstr::convert_DVTOVS" );

  double* data = new double[len];            //-- get data values
  ret = grib_get_double_array( gh, "values", data, &len );
  badRetVal( ret, "grib_get_double_array", "Velstr::convert_DVTOVS" );

  long truncIn = 0;                          //-- get truncation
  ret = grib_get_long( gh, "pentagonalResolutionParameterJ", &truncIn );
  badRetVal( ret, "grib_get_long", "Velstr::convert_DVTOVS" );

  int jmuaf = (trunc_out+1)*(trunc_out+2)+1;
  double* dummy = new double[jmuaf];
  dummy[0] = 0;
  for( int n=1; n < jmuaf; ++n )
  {
     dummy[n] = earths / (double)(n*(n+1));
  }

  int itinp1  = truncIn + 1;
  int itoutp1 = trunc_out + 1;
  int i  = 0;
  int ii = 0;
  for( int m=0; m < itoutp1; ++m )
  {
     for( int n=m; n < itoutp1; ++n )
     {
         data[ii  ] = dummy[n]*data[i];
         data[ii+1] = dummy[n]*data[i+1];
         i  += 2;
         ii += 2;
     }
     i += ( itinp1 - itoutp1 )*2;
  }

  ret = grib_set_long( gh, "pentagonalResolutionParameterJ", trunc_out );
  ret = grib_set_long( gh, "pentagonalResolutionParameterK", trunc_out );
  ret = grib_set_long( gh, "pentagonalResolutionParameterM", trunc_out );

  ret = grib_set_double_array( gh, "values", data, ii );
  badRetVal( ret, "grib_set_double_array", "Velstr::convert_DVTOVS" );

  //trunc = trunc_out;
  delete [] data;
  delete [] dummy;
  return;
}
//_____________________________________________________________________________
#if 0
      SUBROUTINE DVVALID(ISEC1,ISEC2,IERROR)

	integer cputenv

C     VALIDATE THE FIELD
C       Check for vorticity or divergence in spherical harmonics

      DIMENSION ISEC1(*),ISEC2(*)
      INTEGER   IERROR

      IERROR = 0
      IF(ISEC1(6).NE.138.AND.ISEC1(6).NE.155) THEN
C		CALL PUTENV('VELSTR_ENV=FIELD IS NOT VORTICITY OR DIVERGENCE')
		JJ=cputenv('VELSTR_ENV=FIELD IS NOT VORTICITY OR DIVERGENCE')
		IERROR = 1
		RETURN
	ENDIF

      IF(ISEC2(1).NE.50) THEN
C		CALL PUTENV('VELSTR_ENV=FIELD IS NOT SPHERICAL HARMONICS')
		JJ=cputenv('VELSTR_ENV=FIELD IS NOT SPHERICAL HARMONICS')
		IERROR = 1
		RETURN
	ENDIF

      RETURN
      END
#endif

bool
Velstr::isValidData_DVVALID( grib_handle* gh )
{
  const string cVORTICITY ( "138.128" );
  const string cDIVERGENCE( "155.128" );
  const string cSPECTRAL( "sh" );

  const int cBUFLEN = 50;
  char charBuf[ cBUFLEN+1 ];

  size_t len = cBUFLEN;                      //-- is spectral or not?
  int ret = grib_get_string( gh, "gridType", charBuf, &len );
  badRetVal( ret, "grib_get_string/gridType"
           , "Velstr::isValidData_DVVALID" );

  if( string(charBuf) != cSPECTRAL )
  {
     marslog(LOG_EROR,"Velstr: data is '%s', must be spectral ('%s')"
            ,charBuf
            ,cSPECTRAL.c_str() );
     return false;
  }

  long param;
  ret = grib_get_long( gh, "mars.param", &param );
  badRetVal( ret, "grib_get_long/mars.param"
           , "Velstr::isValidData_DVVALID" );

  if( param == atol(cVORTICITY.c_str()) )        //-- if vorticity then OK and change
  {                                              //-- paramId to 1 = Stream function
     ret = grib_set_long( gh, "paramId", 1 );
     badRetVal( ret, "grib_set_long/paramId=1", "Velstr::isValidData_DVVALID" );
     return true;
  }
  if( param == atol(cDIVERGENCE.c_str()) )       //-- if divergence then OK and change
  {                                              //-- param to 2 = Velocity potential
     ret = grib_set_long( gh, "paramId", 2 );
     badRetVal( ret, "grib_set_long/paramId=2", "Velstr::isValidData_DVVALID" );
     return true;
  }

  marslog(LOG_EROR
         ,"Velstr: param is '%s', must be vorticity (%s) or divergence (%s)"
         ,charBuf
         ,cVORTICITY.c_str()
         ,cDIVERGENCE.c_str() );
  return false;
}
//_____________________________________________________________________________
#if 0
      SUBROUTINE BPPSMTH(P,KZ,FLTC,MFLTEXP,NPREL4)
C
C    F. II		ECMWF		SET-92
C    PERFORMS SPATIAL SMOOTHING ON THE SPHERE
C    FILTER IS OF THE FORM
C    SN = EXP( -K*(N(N+1))**R )
C    REF:- SARDESHMUKH AND HOSKINS(1984) MWR,112,P2524
C
C    INPUT :
C	P	: SPECTRAL FIELD
C	KZ	: LENGTH OF ARRAY P
C	FLTC	:
C	MFLTEXP	:
C	NPREL4	:
C
C    OUTPUT :
C	P	: SPECTRAL FIELD SMOOTHED
C
C    ORIGINAL W.A.HECKLEY
C
C
      DIMENSION P(KZ)
C
      PARAMETER (MPLON=1284)
      DIMENSION	DUMMY(MPLON)
C
      FLTCONS = -1./((FLTC*(FLTC+1))**MFLTEXP)
      WRITE(*,'('' SPATIAL SMOOTHING,   K = '',E13.4)')FLTCONS
      WRITE(*,'(''               EXPONENT = ''I3)')MFLTEXP

      ITINP1 = NPREL4
      DUMMY(1) = 1.0
      DO 1 N=2,ITINP1
         DUMMY(N) = EXP( FLTCONS*FLOAT( ((N-1)*N)**MFLTEXP ))
 1    CONTINUE
C
CDIR$ IVDEP
      I  = 1
      II = 1
      DO 2 M=1,ITINP1
         DO 20 N=M,ITINP1
            P(II  ) = DUMMY(N)*P(I  )
            P(II+1) = DUMMY(N)*P(I+1)
              I     = I  + 2
              II    = II + 2
 20      CONTINUE
 2    CONTINUE
C
      RETURN
      END
#endif

bool
Velstr::smooth_BPPSMTH( grib_handle* gh )
{
  size_t len = 0;                              //-- data values count
  int ret = grib_get_size( gh, "values", &len );
  badRetVal( ret, "grib_get_size", "Velstr::smooth_BPPSMTH" );

  double* data = new double[len];            //-- get data values
  ret = grib_get_double_array( gh, "values", data, &len );
  badRetVal( ret, "grib_get_double_array", "Velstr::smooth_BPPSMTH" );

  long truncIn = 0;                          //-- get truncation
  ret = grib_get_long( gh, "pentagonalResolutionParameterJ", &truncIn );
  badRetVal( ret, "pentagonalResolutionParameterJ", "Velstr::smooth_BPPSMTH" );

                                             //-- prepare smoothing stuff
  double fltcons = -1./pow( Vfltc*(Vfltc+1), Vmfltexp );
  sendProgress( "Spatial smoothing, Fltc = %g, Mfltexp = %g"
              , Vfltc, Vmfltexp );
  cout << "Spatial smoothing, Fltc = " << Vfltc
       << ",  Mfltexp = " << Vmfltexp << endl;

  long itinp1 = truncIn;  //-- NPREL4
  double* dummy = new double[ itinp1 ];      //-- compute final smoothing coefficients
  dummy[0] = 1.0;
  for( int n=1; n<itinp1; ++n )
  {
     dummy[ n ] = exp( fltcons * pow( (double)(n*(n+1)), Vmfltexp ) );
  }

  int i  = 0;                                //-- do the smoothing
  int ii = 0;
  for( int m=0; m<itinp1; ++m )
  for( int n=m; n<itinp1; ++n )
  {
     data[ ii   ] = dummy[ n ] * data[ i   ];
     data[ ii+1 ] = dummy[ n ] * data[ i+1 ];
     i  += 2;
     ii += 2;
  }
                                             //-- put back the smoothed data
  ret = grib_set_double_array( gh, "values", data, len );
  badRetVal( ret, "grib_set_double_array", "Velstr::smooth_BPPSMTH" );

  delete [] dummy;
  delete [] data;

  return true;
}

void
Velstr::scaleData( grib_handle* gh )
{
  size_t len = 0;                              //-- data values count
  int ret = grib_get_size( gh, "values", &len );
  badRetVal( ret, "grib_get_size", "Velstr::scaleData" );

  double* data = new double[len];            //-- get data values
  ret = grib_get_double_array( gh, "values", data, &len );
  badRetVal( ret, "grib_get_double_array", "Velstr::scaleData" );

  sendProgress( "Output data scaled" );
  cout << "Output data scaled" << endl;

  for( int i=0; i<len; ++i )
  {
     data[ i ] *= 0.000001;
  }
                                             //-- put back the scaled data
  ret = grib_set_double_array( gh, "values", data, len );
  badRetVal( ret, "grib_set_double_array", "Velstr::scaleData" );

  delete [] data;
}

bool
Velstr::checkOutputTruncation( grib_handle* gh )
{
  long truncIn = 0;                          //-- get truncation
  int ret = grib_get_long( gh, "pentagonalResolutionParameterJ", &truncIn );
  badRetVal( ret, "pentagonalResolutionParameterJ", "Velstr::smooth_BPPSMTH" );

  if( Vtrunc > truncIn )
  {
     marslog( LOG_EROR, "Oops, requested output truncation %d greater than input %d..."
            , Vtrunc, (int)truncIn );
     marslog( LOG_EROR, "... setting output truncation to %d", (int)truncIn );
     cerr << "Oops, requested output truncation " << Vtrunc
          << " greater than input " << truncIn << endl
          << "... setting output truncation to " << truncIn << endl;

     Vtrunc = truncIn;                       //-- fall back to input truncation

     return false;
  }
  else
     return true;
}
