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