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: matriceun, matriceus, matricevn, matricevs, matrinvn, &
         matrinvs
    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 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			! Author: P. Le Van
11			! Objet : filtre matriciel longitudinal, avec les matrices précalculées
12			! pour l'opérateur filtre.
13	guez	3
14	guez	27	USE dimens_m, ONLY : iim, jjm
15	guez	32	USE parafilt, ONLY: matriceun, matriceus, matricevn, matricevs, matrinvn, &
16			matrinvs
17	guez	27	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 eignq(iim), sdd1(iim), sdd2(iim)
52			INTEGER hemisph
53	guez	25
54	guez	27	!-----------------------------------------------------------
55	guez	25
56	guez	27	IF (ifiltre==1 .OR. ifiltre==-1) STOP &
57			'Pas de transformee simple dans cette version'
58	guez	25
59	guez	27	IF (iter==2) THEN
60			PRINT *, ' Pas d iteration du filtre dans cette version !', &
61			' Utiliser old_filtreg et repasser !'
62			STOP
63			END IF
64	guez	25
65	guez	27	IF (ifiltre==-2 .AND. .NOT. griscal) THEN
66			PRINT *, ' Cette routine ne calcule le filtre inverse que ', &
67			' sur la grille des scalaires !'
68			STOP
69			END IF
70	guez	25
71	guez	27	IF (ifiltre/=2 .AND. ifiltre/=-2) THEN
72			PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &
73			' corriger et repasser !'
74			STOP
75			END IF
76	guez	25
77	guez	27	IF (griscal) THEN
78			IF (nlat /= jjm + 1) THEN
79			PRINT 1111
80			STOP
81			ELSE
82	guez	25
83	guez	27	IF (iaire==1) THEN
84	guez	30	sdd1 = sddv
85			sdd2 = unsddv
86	guez	27	ELSE
87	guez	30	sdd1 = unsddv
88			sdd2 = sddv
89	guez	27	END IF
90	guez	25
91	guez	27	jdfil1 = 2
92			jffil1 = jfiltnu
93			jdfil2 = jfiltsu
94			jffil2 = jjm
95			END IF
96			ELSE
97			IF (nlat/=jjm) THEN
98			PRINT 2222
99			STOP
100			ELSE
101	guez	25
102	guez	27	IF (iaire==1) THEN
103	guez	30	sdd1 = sddu
104			sdd2 = unsddu
105	guez	27	ELSE
106	guez	30	sdd1 = unsddu
107			sdd2 = sddu
108	guez	27	END IF
109	guez	25
110	guez	27	jdfil1 = 1
111			jffil1 = jfiltnv
112			jdfil2 = jfiltsv
113			jffil2 = jjm
114			END IF
115			END IF
116	guez	25
117
118	guez	27	DO hemisph = 1, 2
119	guez	25
120	guez	27	IF (hemisph==1) THEN
121			jdfil = jdfil1
122			jffil = jffil1
123			ELSE
124			jdfil = jdfil2
125			jffil = jffil2
126			END IF
127	guez	25
128
129	guez	27	DO l = 1, nbniv
130			DO j = jdfil, jffil
131	guez	25
132
133	guez	27	DO i = 1, iim
134			champ(i, j, l) = champ(i, j, l)*sdd1(i)
135			END DO
136	guez	25
137
138	guez	27	IF (hemisph==1) THEN
139	guez	25
140	guez	27	IF (ifiltre==-2) THEN
141			DO k = 1, iim
142			eignq(k) = 0.0
143			END DO
144			DO k = 1, iim
145			DO i = 1, iim
146			eignq(k) = eignq(k) + matrinvn(k, i, j)*champ(i, j, l)
147			END DO
148			END DO
149			ELSE IF (griscal) THEN
150			DO k = 1, iim
151			eignq(k) = 0.0
152			END DO
153			DO i = 1, iim
154			DO k = 1, iim
155	guez	32	eignq(k) = eignq(k) + matriceun(k, i, j) &
156			* champ(i, j, l)
157	guez	27	END DO
158			END DO
159			ELSE
160			DO k = 1, iim
161			eignq(k) = 0.0
162			END DO
163			DO i = 1, iim
164			DO k = 1, iim
165	guez	32	eignq(k) = eignq(k) + matricevn(k, i, j) &
166			* champ(i, j, l)
167	guez	27	END DO
168			END DO
169			END IF
170	guez	25
171	guez	27	ELSE
172	guez	25
173	guez	27	IF (ifiltre==-2) THEN
174			DO k = 1, iim
175			eignq(k) = 0.0
176			END DO
177			DO i = 1, iim
178			DO k = 1, iim
179			eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1) &
180			*champ(i, j, l)
181			END DO
182			END DO
183			ELSE IF (griscal) THEN
184			DO k = 1, iim
185			eignq(k) = 0.0
186			END DO
187			DO i = 1, iim
188			DO k = 1, iim
189			eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1) &
190			*champ(i, j , l)
191			END DO
192			END DO
193			ELSE
194			DO k = 1, iim
195			eignq(k) = 0.0
196			END DO
197			DO i = 1, iim
198			DO k = 1, iim
199			eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1) &
200			*champ(i, j , l)
201			END DO
202			END DO
203			END IF
204	guez	25
205	guez	27	END IF
206	guez	25
207	guez	27	IF (ifiltre==2) THEN
208			DO i = 1, iim
209			champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)
210			end DO
211			ELSE
212			DO i = 1, iim
213			champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)
214			end DO
215			END IF
216	guez	25
217	guez	27	champ(iim + 1, j, l) = champ(1, j, l)
218	guez	25
219	guez	27	END DO
220	guez	25
221	guez	27	END DO
222
223			end DO
224
225	guez	25	1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
226	guez	27	& CHAMP a filtrer, sur la grille des scalaires'/)
227	guez	25	2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
228	guez	27	&CHAMP a filtrer, sur la grille de V ou de Z'/)
229	guez	25
230	guez	27	END SUBROUTINE filtreg
231
232			end module filtreg_m