trunk/filtrez/filtreg_scal.f

SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)

  ! From filtrez/filtreg.F, version 1.1.1.1 2004/05/19 12:53:09

  ! Auteur: P. Le Van 07/10/97 
  ! Objet: filtre matriciel longitudinal, avec les matrices précalculées
  ! pour l'operateur filtre. 

  USE dimens_m
  USE paramet_m
  USE parafilt
  USE coefils

  IMPLICIT NONE

  INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
  integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer 

  REAL, intent(inout):: champ(iip1, nlat, nbniv)
  ! en entree : champ a filtrer, en sortie : champ filtre

  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/=jjp1) 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(iip1, 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
1	SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)
2
3	! From filtrez/filtreg.F, version 1.1.1.1 2004/05/19 12:53:09
4
5	! Auteur: P. Le Van 07/10/97
6	! Objet: filtre matriciel longitudinal, avec les matrices précalculées
7	! pour l'operateur filtre.
8
9	USE dimens_m
10	USE paramet_m
11	USE parafilt
12	USE coefils
13
14	IMPLICIT NONE
15
16	INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
17	integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer
18
19	REAL, intent(inout):: champ(iip1, nlat, nbniv)
20	! en entree : champ a filtrer, en sortie : champ filtre
21
22	integer, intent(in):: ifiltre
23	! +1 Transformee directe
24	! -1 Transformee inverse
25	! +2 Filtre directe
26	! -2 Filtre inverse
27	! Variable Intensive
28	! ifiltre = 1 filtre directe
29	! ifiltre =-1 filtre inverse
30	! Variable Extensive
31	! ifiltre = 2 filtre directe
32	! ifiltre =-2 filtre inverse
33
34	integer, intent(in):: iaire
35	! 1 si champ intensif
36	! 2 si champ extensif (pondere par les aires)
37
38	integer, intent(in):: iter
39	! 1 filtre simple
40
41	LOGICAL, intent(in):: griscal
42
43	! Variables local to the procedure:
44
45	INTEGER jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
46	INTEGER i, j, l, k
47	REAL matriceun, matriceus, matricevn, matricevs, matrinvn, matrinvs
48	COMMON /matrfil/matriceun(iim, iim, nfilun), matriceus(iim, iim, nfilus), &
49	matricevn(iim, iim, nfilvn), matricevs(iim, iim, nfilvs), &
50	matrinvn(iim, iim, nfilun), matrinvs(iim, iim, nfilus)
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/=jjp1) THEN
79	PRINT 1111
80	STOP
81	ELSE
82
83	IF (iaire==1) THEN
84	CALL scopy(iim, sddv, 1, sdd1, 1)
85	CALL scopy(iim, unsddv, 1, sdd2, 1)
86	ELSE
87	CALL scopy(iim, unsddv, 1, sdd1, 1)
88	CALL scopy(iim, sddv, 1, sdd2, 1)
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	CALL scopy(iim, sddu, 1, sdd1, 1)
104	CALL scopy(iim, unsddu, 1, sdd2, 1)
105	ELSE
106	CALL scopy(iim, unsddu, 1, sdd1, 1)
107	CALL scopy(iim, sddu, 1, sdd2, 1)
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)*champ(i, j, l)
156	END DO
157	END DO
158	ELSE
159	DO k = 1, iim
160	eignq(k) = 0.0
161	END DO
162	DO i = 1, iim
163	DO k = 1, iim
164	eignq(k) = eignq(k) + matricevn(k, i, j)*champ(i, j, l)
165	END DO
166	END DO
167	END IF
168
169	ELSE
170
171	IF (ifiltre==-2) THEN
172	DO k = 1, iim
173	eignq(k) = 0.0
174	END DO
175	DO i = 1, iim
176	DO k = 1, iim
177	eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1)*champ(i, j, &
178	l)
179	END DO
180	END DO
181	ELSE IF (griscal) THEN
182	DO k = 1, iim
183	eignq(k) = 0.0
184	END DO
185	DO i = 1, iim
186	DO k = 1, iim
187	eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1)*champ(i, j &
188	, l)
189	END DO
190	END DO
191	ELSE
192	DO k = 1, iim
193	eignq(k) = 0.0
194	END DO
195	DO i = 1, iim
196	DO k = 1, iim
197	eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1)*champ(i, j &
198	, l)
199	END DO
200	END DO
201	END IF
202
203	END IF
204
205	IF (ifiltre==2) THEN
206	DO i = 1, iim
207	champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)
208	end DO
209	ELSE
210	DO i = 1, iim
211	champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)
212	end DO
213	END IF
214
215	champ(iip1, j, l) = champ(1, j, l)
216
217	END DO
218
219	END DO
220
221	end DO
222
223	1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
224	& CHAMP a filtrer, sur la grille des scalaires'/)
225	2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
226	&CHAMP a filtrer, sur la grille de V ou de Z'/)
227
228	END SUBROUTINE filtreg