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	module filtreg_m
2
3	IMPLICIT NONE
4
5	contains
6
7	SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)
8
9	! 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
14	USE dimens_m, ONLY : iim, jjm
15	USE parafilt, ONLY: matriceun, matriceus, matricevn, matricevs, matrinvn, &
16	matrinvs
17	USE coefils, ONLY : jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, &
18	unsddu, unsddv
19
20	INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
21	integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer
22
23	REAL, intent(inout):: champ(iim + 1, nlat, nbniv)
24	! en entrée : champ à filtrer, en sortie : champ filtré
25
26	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
38	integer, intent(in):: iaire
39	! 1 si champ intensif
40	! 2 si champ extensif (pondere par les aires)
41
42	integer, intent(in):: iter
43	! 1 filtre simple
44
45	LOGICAL, intent(in):: griscal
46
47	! Variables local to the procedure:
48
49	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
54	!-----------------------------------------------------------
55
56	IF (ifiltre==1 .OR. ifiltre==-1) STOP &
57	'Pas de transformee simple dans cette version'
58
59	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
65	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
71	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
77	IF (griscal) THEN
78	IF (nlat /= jjm + 1) THEN
79	PRINT 1111
80	STOP
81	ELSE
82
83	IF (iaire==1) THEN
84	sdd1 = sddv
85	sdd2 = unsddv
86	ELSE
87	sdd1 = unsddv
88	sdd2 = sddv
89	END IF
90
91	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
102	IF (iaire==1) THEN
103	sdd1 = sddu
104	sdd2 = unsddu
105	ELSE
106	sdd1 = unsddu
107	sdd2 = sddu
108	END IF
109
110	jdfil1 = 1
111	jffil1 = jfiltnv
112	jdfil2 = jfiltsv
113	jffil2 = jjm
114	END IF
115	END IF
116
117
118	DO hemisph = 1, 2
119
120	IF (hemisph==1) THEN
121	jdfil = jdfil1
122	jffil = jffil1
123	ELSE
124	jdfil = jdfil2
125	jffil = jffil2
126	END IF
127
128
129	DO l = 1, nbniv
130	DO j = jdfil, jffil
131
132
133	DO i = 1, iim
134	champ(i, j, l) = champ(i, j, l)*sdd1(i)
135	END DO
136
137
138	IF (hemisph==1) THEN
139
140	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	eignq(k) = eignq(k) + matriceun(k, i, j) &
156	* champ(i, j, l)
157	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	eignq(k) = eignq(k) + matricevn(k, i, j) &
166	* champ(i, j, l)
167	END DO
168	END DO
169	END IF
170
171	ELSE
172
173	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
205	END IF
206
207	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
217	champ(iim + 1, j, l) = champ(1, j, l)
218
219	END DO
220
221	END DO
222
223	end DO
224
225	1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
226	& CHAMP a filtrer, sur la grille des scalaires'/)
227	2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
228	&CHAMP a filtrer, sur la grille de V ou de Z'/)
229
230	END SUBROUTINE filtreg
231
232	end module filtreg_m