*=*=*=*= afiltreg.html =*=*=*=*
SUBROUTINE afiltreg

SUBROUTINE afiltreg


      SUBROUTINE afiltreg ( champ, nlat, nbniv, ifiltre,iaire,
     .   griscal ,iter)
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
c        return

      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  1
             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  2
             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 888 j=1,iim
       DO 888 i=1,iim
       eignfn2(i,j)=eignfn(j,i)
888    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 889 j=jdfil,jffil
       kfm(j)=iim - modfrst(j)+1
889    continue

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

      kf = modfrst(j)

      champ(1,j,l )=champ(1,j,l )+champ( iip1,j,l )
      champ( iip1,j,l )=0.

      IF(ifiltre.eq.2)THEN
        DO 15 i = 1, iim
        eignq(i)=champ(i,j,l)*sdd2(i)
        champ(i,j,l)=champ(i,j,l)*sdd2(i)
15      CONTINUE
      ELSE
        DO 16 i=1,iim
         eignq(i)=-champ( i,j,l )*sdd2(i)
         champ(i,j,l)=champ(i,j,l)*sdd2(i)
16      CONTINUE
      ENDIF
c

      do k=1,iim
         qf(k)=0.
      enddo
      CALL aMXV_adj(eignfn(1,kf),iim,qf(kf),iim-kf+1, eignq )

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

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



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

c     champ(iip1,j,l)=champ(1,j,l)

  30  CONTINUE
c
  50  CONTINUE
c
 100  CONTINUE
c
   1  FORMAT(//20x'ERREUR dans le dimensionnement du tableau CHAMP a fil-
     *trer, sur la grille des scalaires'/)
   2  FORMAT(//20x'ERREUR dans le dimensionnement du tableau CHAMP a fil-
     *trer, sur la grille de V ou de Z'/)
      RETURN
      END