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	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
11	! Author: P. Le Van
12	! Objet : filtre matriciel longitudinal, avec les matrices précalculées
13	! pour l'opérateur filtre.
14
15	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
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 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
58	!-----------------------------------------------------------
59
60	IF (ifiltre==1 .OR. ifiltre==-1) STOP &
61	'Pas de transformee simple dans cette version'
62
63	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
69	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
75	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
81	IF (griscal) THEN
82	IF (nlat /= jjm + 1) THEN
83	PRINT 1111
84	STOP
85	ELSE
86
87	IF (iaire==1) THEN
88	sdd1 = sddv
89	sdd2 = unsddv
90	ELSE
91	sdd1 = unsddv
92	sdd2 = sddv
93	END IF
94
95	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
106	IF (iaire==1) THEN
107	sdd1 = sddu
108	sdd2 = unsddu
109	ELSE
110	sdd1 = unsddu
111	sdd2 = sddu
112	END IF
113
114	jdfil1 = 1
115	jffil1 = jfiltnv
116	jdfil2 = jfiltsv
117	jffil2 = jjm
118	END IF
119	END IF
120
121
122	DO hemisph = 1, 2
123
124	IF (hemisph==1) THEN
125	jdfil = jdfil1
126	jffil = jffil1
127	ELSE
128	jdfil = jdfil2
129	jffil = jffil2
130	END IF
131
132
133	DO l = 1, nbniv
134	DO j = jdfil, jffil
135
136
137	DO i = 1, iim
138	champ(i, j, l) = champ(i, j, l)*sdd1(i)
139	END DO
140
141
142	IF (hemisph==1) THEN
143
144	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
173	ELSE
174
175	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
207	END IF
208
209	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
219	champ(iim + 1, j, l) = champ(1, j, l)
220
221	END DO
222
223	END DO
224
225	end DO
226
227	1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
228	& CHAMP a filtrer, sur la grille des scalaires'/)
229	2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
230	&CHAMP a filtrer, sur la grille de V ou de Z'/)
231
232	END SUBROUTINE filtreg
233
234	end module filtreg_m