trunk/filtrez/filtreg_scal.f

module filtreg_m

  IMPLICIT NONE

contains

  SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)

    ! From filtrez/filtreg.F, version 1.1.1.1, 2004/05/19 12:53:09

    ! Author: P. Le Van
    ! Objet : filtre matriciel longitudinal, avec les matrices précalculées
    ! pour l'opérateur filtre. 

    USE dimens_m, ONLY : iim, jjm
    USE parafilt, ONLY : nfilun, nfilus, nfilvn, nfilvs
    USE coefils, ONLY : jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, &
         unsddu, unsddv

    INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
    integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer 

    REAL, intent(inout):: champ(iim + 1, nlat, nbniv)
    ! en entrée : champ à filtrer, en sortie : champ filtré

    integer, intent(in):: ifiltre
    !  +1 Transformee directe 
    ! -1 Transformee inverse 
    ! +2 Filtre directe 
    ! -2 Filtre inverse 
    ! Variable Intensive 
    ! ifiltre = 1 filtre directe 
    ! ifiltre =-1 filtre inverse 
    ! Variable Extensive 
    ! ifiltre = 2 filtre directe 
    ! ifiltre =-2 filtre inverse

    integer, intent(in):: iaire
    !  1 si champ intensif 
    ! 2 si champ extensif (pondere par les aires)

    integer, intent(in):: iter
    !  1 filtre simple 

    LOGICAL, intent(in):: griscal

    ! Variables local to the procedure:

    INTEGER jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
    INTEGER i, j, l, k
    REAL matriceun, matriceus, matricevn, matricevs, matrinvn, matrinvs
    COMMON /matrfil/matriceun(iim, iim, nfilun), matriceus(iim, iim, nfilus), &
         matricevn(iim, iim, nfilvn), matricevs(iim, iim, nfilvs), &
         matrinvn(iim, iim, nfilun), matrinvs(iim, iim, nfilus)
    REAL eignq(iim), sdd1(iim), sdd2(iim)
    INTEGER hemisph

    !-----------------------------------------------------------

    IF (ifiltre==1 .OR. ifiltre==-1) STOP &
         'Pas de transformee simple dans cette version'

    IF (iter==2) THEN
       PRINT *, ' Pas d iteration du filtre dans cette version !', &
            ' Utiliser old_filtreg et repasser !'
       STOP
    END IF

    IF (ifiltre==-2 .AND. .NOT. griscal) THEN
       PRINT *, ' Cette routine ne calcule le filtre inverse que ', &
            ' sur la grille des scalaires !'
       STOP
    END IF

    IF (ifiltre/=2 .AND. ifiltre/=-2) THEN
       PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &
            ' corriger et repasser !'
       STOP
    END IF

    IF (griscal) THEN
       IF (nlat /= jjm + 1) THEN
          PRINT 1111
          STOP
       ELSE

          IF (iaire==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

          jdfil1 = 2
          jffil1 = jfiltnu
          jdfil2 = jfiltsu
          jffil2 = jjm
       END IF
    ELSE
       IF (nlat/=jjm) THEN
          PRINT 2222
          STOP
       ELSE

          IF (iaire==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

          jdfil1 = 1
          jffil1 = jfiltnv
          jdfil2 = jfiltsv
          jffil2 = jjm
       END IF
    END IF


    DO hemisph = 1, 2

       IF (hemisph==1) THEN
          jdfil = jdfil1
          jffil = jffil1
       ELSE
          jdfil = jdfil2
          jffil = jffil2
       END IF


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


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


             IF (hemisph==1) THEN

                IF (ifiltre==-2) THEN
                   DO k = 1, iim
                      eignq(k) = 0.0
                   END DO
                   DO k = 1, iim
                      DO i = 1, iim
                         eignq(k) = eignq(k) + matrinvn(k, i, j)*champ(i, j, l)
                      END DO
                   END DO
                ELSE IF (griscal) THEN
                   DO k = 1, iim
                      eignq(k) = 0.0
                   END DO
                   DO i = 1, iim
                      DO k = 1, iim
                         eignq(k) = eignq(k) + matriceun(k, i, j)*champ(i, j, l)
                      END DO
                   END DO
                ELSE
                   DO k = 1, iim
                      eignq(k) = 0.0
                   END DO
                   DO i = 1, iim
                      DO k = 1, iim
                         eignq(k) = eignq(k) + matricevn(k, i, j)*champ(i, j, l)
                      END DO
                   END DO
                END IF

             ELSE

                IF (ifiltre==-2) THEN
                   DO k = 1, iim
                      eignq(k) = 0.0
                   END DO
                   DO i = 1, iim
                      DO k = 1, iim
                         eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1) &
                              *champ(i, j, l)
                      END DO
                   END DO
                ELSE IF (griscal) THEN
                   DO k = 1, iim
                      eignq(k) = 0.0
                   END DO
                   DO i = 1, iim
                      DO k = 1, iim
                         eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1) &
                              *champ(i, j , l)
                      END DO
                   END DO
                ELSE
                   DO k = 1, iim
                      eignq(k) = 0.0
                   END DO
                   DO i = 1, iim
                      DO k = 1, iim
                         eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1) &
                              *champ(i, j , l)
                      END DO
                   END DO
                END IF

             END IF

             IF (ifiltre==2) THEN
                DO i = 1, iim
                   champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)
                end DO
             ELSE
                DO i = 1, iim
                   champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)
                end DO
             END IF

             champ(iim + 1, j, l) = champ(1, j, l)

          END DO

       END DO

    end DO

1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
         & CHAMP a filtrer, sur la grille des scalaires'/)
2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
         &CHAMP a filtrer, sur la grille de V ou de Z'/)

  END SUBROUTINE filtreg

end module filtreg_m
1	guez	27	module filtreg_m
2	guez	3
3	guez	27	IMPLICIT NONE
4	guez	3
5	guez	27	contains
6	guez	3
7	guez	27	SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)
8	guez	3
9	guez	27	! From filtrez/filtreg.F, version 1.1.1.1, 2004/05/19 12:53:09
10	guez	3
11	guez	27	! Author: P. Le Van
12			! Objet : filtre matriciel longitudinal, avec les matrices précalculées
13			! pour l'opérateur filtre.
14	guez	3
15	guez	27	USE dimens_m, ONLY : iim, jjm
16			USE parafilt, ONLY : nfilun, nfilus, nfilvn, nfilvs
17			USE coefils, ONLY : jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, &
18			unsddu, unsddv
19	guez	3
20	guez	27	INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
21			integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer
22	guez	3
23	guez	27	REAL, intent(inout):: champ(iim + 1, nlat, nbniv)
24			! en entrée : champ à filtrer, en sortie : champ filtré
25	guez	3
26	guez	27	integer, intent(in):: ifiltre
27			! +1 Transformee directe
28			! -1 Transformee inverse
29			! +2 Filtre directe
30			! -2 Filtre inverse
31			! Variable Intensive
32			! ifiltre = 1 filtre directe
33			! ifiltre =-1 filtre inverse
34			! Variable Extensive
35			! ifiltre = 2 filtre directe
36			! ifiltre =-2 filtre inverse
37	guez	3
38	guez	27	integer, intent(in):: iaire
39			! 1 si champ intensif
40			! 2 si champ extensif (pondere par les aires)
41	guez	3
42	guez	27	integer, intent(in):: iter
43			! 1 filtre simple
44	guez	3
45	guez	27	LOGICAL, intent(in):: griscal
46	guez	3
47	guez	27	! Variables local to the procedure:
48	guez	25
49	guez	27	INTEGER jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
50			INTEGER i, j, l, k
51			REAL matriceun, matriceus, matricevn, matricevs, matrinvn, matrinvs
52			COMMON /matrfil/matriceun(iim, iim, nfilun), matriceus(iim, iim, nfilus), &
53			matricevn(iim, iim, nfilvn), matricevs(iim, iim, nfilvs), &
54			matrinvn(iim, iim, nfilun), matrinvs(iim, iim, nfilus)
55			REAL eignq(iim), sdd1(iim), sdd2(iim)
56			INTEGER hemisph
57	guez	25
58	guez	27	!-----------------------------------------------------------
59	guez	25
60	guez	27	IF (ifiltre==1 .OR. ifiltre==-1) STOP &
61			'Pas de transformee simple dans cette version'
62	guez	25
63	guez	27	IF (iter==2) THEN
64			PRINT *, ' Pas d iteration du filtre dans cette version !', &
65			' Utiliser old_filtreg et repasser !'
66			STOP
67			END IF
68	guez	25
69	guez	27	IF (ifiltre==-2 .AND. .NOT. griscal) THEN
70			PRINT *, ' Cette routine ne calcule le filtre inverse que ', &
71			' sur la grille des scalaires !'
72			STOP
73			END IF
74	guez	25
75	guez	27	IF (ifiltre/=2 .AND. ifiltre/=-2) THEN
76			PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &
77			' corriger et repasser !'
78			STOP
79			END IF
80	guez	25
81	guez	27	IF (griscal) THEN
82			IF (nlat /= jjm + 1) THEN
83			PRINT 1111
84			STOP
85			ELSE
86	guez	25
87	guez	27	IF (iaire==1) THEN
88			CALL scopy(iim, sddv, 1, sdd1, 1)
89			CALL scopy(iim, unsddv, 1, sdd2, 1)
90			ELSE
91			CALL scopy(iim, unsddv, 1, sdd1, 1)
92			CALL scopy(iim, sddv, 1, sdd2, 1)
93			END IF
94	guez	25
95	guez	27	jdfil1 = 2
96			jffil1 = jfiltnu
97			jdfil2 = jfiltsu
98			jffil2 = jjm
99			END IF
100			ELSE
101			IF (nlat/=jjm) THEN
102			PRINT 2222
103			STOP
104			ELSE
105	guez	25
106	guez	27	IF (iaire==1) THEN
107			CALL scopy(iim, sddu, 1, sdd1, 1)
108			CALL scopy(iim, unsddu, 1, sdd2, 1)
109			ELSE
110			CALL scopy(iim, unsddu, 1, sdd1, 1)
111			CALL scopy(iim, sddu, 1, sdd2, 1)
112			END IF
113	guez	25
114	guez	27	jdfil1 = 1
115			jffil1 = jfiltnv
116			jdfil2 = jfiltsv
117			jffil2 = jjm
118			END IF
119			END IF
120	guez	25
121
122	guez	27	DO hemisph = 1, 2
123	guez	25
124	guez	27	IF (hemisph==1) THEN
125			jdfil = jdfil1
126			jffil = jffil1
127			ELSE
128			jdfil = jdfil2
129			jffil = jffil2
130			END IF
131	guez	25
132
133	guez	27	DO l = 1, nbniv
134			DO j = jdfil, jffil
135	guez	25
136
137	guez	27	DO i = 1, iim
138			champ(i, j, l) = champ(i, j, l)*sdd1(i)
139			END DO
140	guez	25
141
142	guez	27	IF (hemisph==1) THEN
143	guez	25
144	guez	27	IF (ifiltre==-2) THEN
145			DO k = 1, iim
146			eignq(k) = 0.0
147			END DO
148			DO k = 1, iim
149			DO i = 1, iim
150			eignq(k) = eignq(k) + matrinvn(k, i, j)*champ(i, j, l)
151			END DO
152			END DO
153			ELSE IF (griscal) THEN
154			DO k = 1, iim
155			eignq(k) = 0.0
156			END DO
157			DO i = 1, iim
158			DO k = 1, iim
159			eignq(k) = eignq(k) + matriceun(k, i, j)*champ(i, j, l)
160			END DO
161			END DO
162			ELSE
163			DO k = 1, iim
164			eignq(k) = 0.0
165			END DO
166			DO i = 1, iim
167			DO k = 1, iim
168			eignq(k) = eignq(k) + matricevn(k, i, j)*champ(i, j, l)
169			END DO
170			END DO
171			END IF
172	guez	25
173	guez	27	ELSE
174	guez	25
175	guez	27	IF (ifiltre==-2) THEN
176			DO k = 1, iim
177			eignq(k) = 0.0
178			END DO
179			DO i = 1, iim
180			DO k = 1, iim
181			eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1) &
182			*champ(i, j, l)
183			END DO
184			END DO
185			ELSE IF (griscal) THEN
186			DO k = 1, iim
187			eignq(k) = 0.0
188			END DO
189			DO i = 1, iim
190			DO k = 1, iim
191			eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1) &
192			*champ(i, j , l)
193			END DO
194			END DO
195			ELSE
196			DO k = 1, iim
197			eignq(k) = 0.0
198			END DO
199			DO i = 1, iim
200			DO k = 1, iim
201			eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1) &
202			*champ(i, j , l)
203			END DO
204			END DO
205			END IF
206	guez	25
207	guez	27	END IF
208	guez	25
209	guez	27	IF (ifiltre==2) THEN
210			DO i = 1, iim
211			champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)
212			end DO
213			ELSE
214			DO i = 1, iim
215			champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)
216			end DO
217			END IF
218	guez	25
219	guez	27	champ(iim + 1, j, l) = champ(1, j, l)
220	guez	25
221	guez	27	END DO
222	guez	25
223	guez	27	END DO
224
225			end DO
226
227	guez	25	1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
228	guez	27	& CHAMP a filtrer, sur la grille des scalaires'/)
229	guez	25	2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
230	guez	27	&CHAMP a filtrer, sur la grille de V ou de Z'/)
231	guez	25
232	guez	27	END SUBROUTINE filtreg
233
234			end module filtreg_m