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
             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	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	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
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	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
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