trunk/filtrez/filtreg_scal.f

module filtreg_m

  IMPLICIT NONE

contains

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

    ! 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 coefils, ONLY: sddu, sddv, unsddu, unsddv
    USE dimens_m, ONLY: iim, jjm
    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)

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