libf/filtrez/filtreg.f90

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	guez	25	SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)
2	guez	3
3	guez	25	! From filtrez/filtreg.F, version 1.1.1.1 2004/05/19 12:53:09
4	guez	3
5	guez	25	! Auteur: P. Le Van 07/10/97
6			! Objet: filtre matriciel longitudinal, avec les matrices précalculées
7			! pour l'operateur filtre.
8	guez	3
9	guez	25	USE dimens_m
10			USE paramet_m
11			USE parafilt
12			USE coefils
13	guez	3
14	guez	25	IMPLICIT NONE
15	guez	3
16	guez	25	INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
17			integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer
18	guez	3
19	guez	25	REAL, intent(inout):: champ(iip1, nlat, nbniv)
20			! en entree : champ a filtrer, en sortie : champ filtre
21	guez	3
22	guez	25	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	guez	3
34	guez	25	integer, intent(in):: iaire
35			! 1 si champ intensif
36			! 2 si champ extensif (pondere par les aires)
37	guez	3
38	guez	25	integer, intent(in):: iter
39			! 1 filtre simple
40	guez	3
41	guez	25	LOGICAL, intent(in):: griscal
42	guez	3
43	guez	25	! Variables local to the procedure:
44	guez	3
45	guez	25	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	guez	3
54	guez	25	!-----------------------------------------------------------
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