*=*=*=*= filtreg.html =*=*=*=*
SUBROUTINE filtreg

SUBROUTINE filtreg


      SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire,
     .   griscal ,iter)
      implicit none
c=======================================================================
c
c   Auteur: Le Van    12/03/91
c   ------
c
c   Objet: filtre longitudinal FFT
c   -----
c
c   Arguments:
c   ----------
c
c      nblat                 nombre de latitudes a filtrer
c      nbniv                 nombre de niveaux verticaux a filtrer
c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
c                            en sortie : champ filtre
c      ifiltre               +1  Transformee directe
c                            -1  Transformee inverse
c                            +2  Filtre directe
c                            -2  Filtre inverse
c      iaire                 1   si champ intensif
c                            2   si champ extensif (pondere par les aires)
c      iiter                 1   filtre simple
c                            2   filtre ittere 2 fois
c
c=======================================================================
c
c
c                      Variable Intensive
c                ifiltre = 1     filtre directe
c                ifiltre =-1     filtre inverse
c
c                      Variable Extensive
c                ifiltre = 2     filtre directe
c                ifiltre =-2     filtre inverse
c
c
#include "dimensions.h"
#include "paramet.h"
#include "coefils.h"
c
      integer nlat,nbniv,ifiltre,iter
      integer i,j,l,k,kf
      integer iim2,immjm
      integer jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil

      real  champ( iip1,nlat,nbniv)
      real  eignfn(iim,iim),coefil(iim,jjm)  ,
     *           eignq(iim), sdd1(iim),sdd2(iim),qf(iim)
      REAL       eignfn2(iim,iim)
      LOGICAL    griscal
      INTEGER    hemisph, kfm(jjm),iaire,modfrst(jjm)
      	real ssum
      	external ssum
c

      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1)
     .    STOP'Pas de transformee simple dans cette version'

      iim2   = iim * iim
      immjm  = iim * jjm
c
c
      IF( griscal )   THEN
         IF( nlat. NE. jjp1 )  THEN
             PRINT  1111
             STOP
         ELSE
#ifdef CRAY
             CALL SCOPY(  jjm, modfrstu, 1, modfrst, 1 )
#else
             CALL SCOPYi(  jjm, modfrstu, 1, modfrst, 1 )
#endif
             CALL SCOPY( iim2,  eignfnv, 1,  eignfn, 1 )
             if(iter.eq.1) then
                CALL SCOPY( immjm,  coefilu, 1,  coefil, 1 )
             else
                CALL SCOPY( immjm,  coefilu2, 1,  coefil, 1 )
             endif
c
             IF( iaire.EQ.1 )  THEN
                CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 )
                CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
             ELSE
                CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
                CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
             END IF
c
             jdfil1 = 2
             jffil1 = jfiltnu
             jdfil2 = jfiltsu
             jffil2 = jjm
          END IF
      ELSE
          IF( nlat.NE.jjm )  THEN
             PRINT  2222
             STOP
          ELSE
#ifdef CRAY
             CALL SCOPY( jjm, modfrstv, 1, modfrst, 1 )
#else
             CALL SCOPYi( jjm, modfrstv, 1, modfrst, 1 )
#endif
             CALL SCOPY( iim2, eignfnu, 1,  eignfn, 1 )
             if(iter.eq.1) then
                CALL SCOPY( immjm, coefilv, 1,  coefil, 1 )
             else
                CALL SCOPY( immjm, coefilv2, 1,  coefil, 1 )
             endif
c
             IF( iaire.EQ.1 )  THEN
                CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 )
                CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
             ELSE
                CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
                CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
             END IF
c
             jdfil1 = 1
             jffil1 = jfiltnv
             jdfil2 = jfiltsv
             jffil2 = jjm
          END IF
      END IF
c
      DO 1 j=1,iim
      DO 1 i=1,iim
      eignfn2(i,j)=eignfn(j,i)
   1  CONTINUE
c
      DO 100  hemisph = 1, 2
c
      IF ( hemisph.EQ.1 )  THEN
          jdfil = jdfil1
          jffil = jffil1
      ELSE
          jdfil = jdfil2
          jffil = jffil2
      END IF

      DO 2 j=jdfil,jffil
       kfm(j)=iim - modfrst(j)+1
   2  CONTINUE

      DO 50  l = 1, nbniv
      DO 30  j = jdfil,jffil

      kf = modfrst(j)

      DO  5  i = 1, iim
      champ(i,j,l) = champ(i,j,l) * sdd1(i)
   5  CONTINUE

      CALL MXVA(eignfn2(kf,1), 1, iim, champ(1,j,l), 1, qf(kf) ,
     *                      1, kfm(j), iim  )

      DO 9 k = kf,iim
      qf(k)  = qf(k) * coefil(k,j)
 9    CONTINUE

c    ----------------------------------------------------------------
c     operation supplementaire pour l'inverse du filtre, c.a.d  pour
c       ifiltre = -2

      IF( ifiltre.eq.-2 )  THEN
         DO 10 k = kf, iim
         qf( k ) = qf( k ) / ( 1. + coefil( k,j ) )
  10     CONTINUE
      END IF

c      fin de l'operation suppl.
c    ----------------------------------------------------------------
c
c      kfm = iim - kf + 1
c
c     eignq(i)= sommation de eignfn(i,k)*qf(k) , avec k = kf, iim
c                                                     i =  1, iim
c
      CALL  MXV( eignfn(1,kf), iim, qf(kf),iim-kf+1, eignq )
c
      IF(ifiltre.eq.2)THEN
        DO 15 i = 1, iim
        champ( i,j,l ) = ( champ(i,j,l) + eignq(i) ) * sdd2(i)
  15    CONTINUE
      ELSE
        DO 16 i=1,iim
        champ( i,j,l ) = ( champ(i,j,l) - eignq(i) ) * sdd2(i)
16      CONTINUE
      ENDIF
c
      champ( iip1,j,l ) = champ( 1,j,l )
c
  30  CONTINUE
c
  50  CONTINUE
c
 100  CONTINUE
c
1111  FORMAT(//20x'ERREUR dans le dimensionnement du tableau CHAMP a fil-
     *trer, sur la grille des scalaires'/)
2222  FORMAT(//20x'ERREUR dans le dimensionnement du tableau CHAMP a fil-
     *trer, sur la grille de V ou de Z'/)
      RETURN
      END