*=*=*=*= filtreg.html =*=*=*=*
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