libf/filtrez/filtreg.f90

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
             sdd1 = sddv
             sdd2 = unsddv
          ELSE
             sdd1 = unsddv
             sdd2 = sddv
          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
             sdd1 = sddu
             sdd2 = unsddu
          ELSE
             sdd1 = unsddu
             sdd2 = sddu
          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	guez	30	sdd1 = sddv
89			sdd2 = unsddv
90	guez	27	ELSE
91	guez	30	sdd1 = unsddv
92			sdd2 = sddv
93	guez	27	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	guez	30	sdd1 = sddu
108			sdd2 = unsddu
109	guez	27	ELSE
110	guez	30	sdd1 = unsddu
111			sdd2 = sddu
112	guez	27	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