trunk/filtrez/filtreg_scal.f

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 coefils, ONLY : sddu, sddv, unsddu, unsddv
    use inifilr_m, only: jfiltnu, jfiltnv, jfiltsu, jfiltsv, matriceun, &
         matriceus, matricevn, matricevs, matrinvn, matrinvs

    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) then
       print *, 'Pas de transformee simple dans cette version'
       STOP 1
    end IF

    IF (iter==2) THEN
       PRINT *, ' Pas d iteration du filtre dans cette version !', &
            ' Utiliser old_filtreg et repasser !'
       STOP 1
    END IF

    IF (ifiltre==-2 .AND. .NOT. griscal) THEN
       PRINT *, ' Cette routine ne calcule le filtre inverse que ', &
            ' sur la grille des scalaires !'
       STOP 1
    END IF

    IF (ifiltre/=2 .AND. ifiltre/=-2) THEN
       PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &
            ' corriger et repasser !'
       STOP 1
    END IF

    IF (griscal) THEN
       IF (nlat /= jjm + 1) THEN
          PRINT *, 'Erreur dans le dimensionnement du tableau CHAMP a ' &
               // 'filtrer, sur la grille des scalaires'
          STOP 1
       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 *, 'Erreur dans le dimensionnement du tableau CHAMP a ' &
               // 'filtrer, sur la grille de V ou de Z'
          STOP 1
       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

       loop_vertical: DO l = 1, nbniv
          loop_latitude: 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.
                   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.
                   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.
                   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.
                   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.
                   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.
                   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 loop_latitude
       END DO loop_vertical
    end DO

  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 coefils, ONLY : sddu, sddv, unsddu, unsddv
16	use inifilr_m, only: jfiltnu, jfiltnv, jfiltsu, jfiltsv, matriceun, &
17	matriceus, matricevn, matricevs, matrinvn, matrinvs
18
19	INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
20	integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer
21
22	REAL, intent(inout):: champ(iim + 1, nlat, nbniv)
23	! en entrée : champ à filtrer, en sortie : champ filtré
24
25	integer, intent(in):: ifiltre
26	! +1 Transformee directe
27	! -1 Transformee inverse
28	! +2 Filtre directe
29	! -2 Filtre inverse
30	! Variable Intensive
31	! ifiltre = 1 filtre directe
32	! ifiltre =-1 filtre inverse
33	! Variable Extensive
34	! ifiltre = 2 filtre directe
35	! ifiltre =-2 filtre inverse
36
37	integer, intent(in):: iaire
38	! 1 si champ intensif
39	! 2 si champ extensif (pondere par les aires)
40
41	integer, intent(in):: iter
42	! 1 filtre simple
43
44	LOGICAL, intent(in):: griscal
45
46	! Variables local to the procedure:
47
48	INTEGER jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
49	INTEGER i, j, l, k
50	REAL eignq(iim), sdd1(iim), sdd2(iim)
51	INTEGER hemisph
52
53	!-----------------------------------------------------------
54
55	IF (ifiltre==1 .OR. ifiltre==-1) then
56	print *, 'Pas de transformee simple dans cette version'
57	STOP 1
58	end IF
59
60	IF (iter==2) THEN
61	PRINT *, ' Pas d iteration du filtre dans cette version !', &
62	' Utiliser old_filtreg et repasser !'
63	STOP 1
64	END IF
65
66	IF (ifiltre==-2 .AND. .NOT. griscal) THEN
67	PRINT *, ' Cette routine ne calcule le filtre inverse que ', &
68	' sur la grille des scalaires !'
69	STOP 1
70	END IF
71
72	IF (ifiltre/=2 .AND. ifiltre/=-2) THEN
73	PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &
74	' corriger et repasser !'
75	STOP 1
76	END IF
77
78	IF (griscal) THEN
79	IF (nlat /= jjm + 1) THEN
80	PRINT *, 'Erreur dans le dimensionnement du tableau CHAMP a ' &
81	// 'filtrer, sur la grille des scalaires'
82	STOP 1
83	ELSE
84	IF (iaire==1) THEN
85	sdd1 = sddv
86	sdd2 = unsddv
87	ELSE
88	sdd1 = unsddv
89	sdd2 = sddv
90	END IF
91
92	jdfil1 = 2
93	jffil1 = jfiltnu
94	jdfil2 = jfiltsu
95	jffil2 = jjm
96	END IF
97	ELSE
98	IF (nlat /= jjm) THEN
99	PRINT *, 'Erreur dans le dimensionnement du tableau CHAMP a ' &
100	// 'filtrer, sur la grille de V ou de Z'
101	STOP 1
102	ELSE
103	IF (iaire==1) THEN
104	sdd1 = sddu
105	sdd2 = unsddu
106	ELSE
107	sdd1 = unsddu
108	sdd2 = sddu
109	END IF
110
111	jdfil1 = 1
112	jffil1 = jfiltnv
113	jdfil2 = jfiltsv
114	jffil2 = jjm
115	END IF
116	END IF
117
118	DO hemisph = 1, 2
119	IF (hemisph==1) THEN
120	jdfil = jdfil1
121	jffil = jffil1
122	ELSE
123	jdfil = jdfil2
124	jffil = jffil2
125	END IF
126
127	loop_vertical: DO l = 1, nbniv
128	loop_latitude: DO j = jdfil, jffil
129	DO i = 1, iim
130	champ(i, j, l) = champ(i, j, l)*sdd1(i)
131	END DO
132
133	IF (hemisph==1) THEN
134	IF (ifiltre==-2) THEN
135	DO k = 1, iim
136	eignq(k) = 0.
137	END DO
138	DO k = 1, iim
139	DO i = 1, iim
140	eignq(k) = eignq(k) + matrinvn(k, i, j)*champ(i, j, l)
141	END DO
142	END DO
143	ELSE IF (griscal) THEN
144	DO k = 1, iim
145	eignq(k) = 0.
146	END DO
147	DO i = 1, iim
148	DO k = 1, iim
149	eignq(k) = eignq(k) + matriceun(k, i, j) &
150	* champ(i, j, l)
151	END DO
152	END DO
153	ELSE
154	DO k = 1, iim
155	eignq(k) = 0.
156	END DO
157	DO i = 1, iim
158	DO k = 1, iim
159	eignq(k) = eignq(k) + matricevn(k, i, j) &
160	* champ(i, j, l)
161	END DO
162	END DO
163	END IF
164	ELSE
165	IF (ifiltre==-2) THEN
166	DO k = 1, iim
167	eignq(k) = 0.
168	END DO
169	DO i = 1, iim
170	DO k = 1, iim
171	eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1) &
172	*champ(i, j, l)
173	END DO
174	END DO
175	ELSE IF (griscal) THEN
176	DO k = 1, iim
177	eignq(k) = 0.
178	END DO
179	DO i = 1, iim
180	DO k = 1, iim
181	eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1) &
182	*champ(i, j , l)
183	END DO
184	END DO
185	ELSE
186	DO k = 1, iim
187	eignq(k) = 0.
188	END DO
189	DO i = 1, iim
190	DO k = 1, iim
191	eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1) &
192	*champ(i, j , l)
193	END DO
194	END DO
195	END IF
196	END IF
197
198	IF (ifiltre==2) THEN
199	DO i = 1, iim
200	champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)
201	end DO
202	ELSE
203	DO i = 1, iim
204	champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)
205	end DO
206	END IF
207
208	champ(iim + 1, j, l) = champ(1, j, l)
209	END DO loop_latitude
210	END DO loop_vertical
211	end DO
212
213	END SUBROUTINE filtreg
214
215	end module filtreg_m