/[lmdze]/trunk/filtrez/filtreg_scal.f
ViewVC logotype

Diff of /trunk/filtrez/filtreg_scal.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 25 by guez, Fri Mar 5 16:43:45 2010 UTC revision 37 by guez, Tue Dec 21 15:45:48 2010 UTC
# Line 1  Line 1 
1  SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)  module filtreg_m
   
   ! 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  
2    
3    IMPLICIT NONE    IMPLICIT NONE
4    
5    INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer  contains
   integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer  
6    
7    REAL, intent(inout):: champ(iip1, nlat, nbniv)    SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, griscal, iter)
   ! en entree : champ a filtrer, en sortie : champ filtre  
8    
9    integer, intent(in):: ifiltre      ! From filtrez/filtreg.F, version 1.1.1.1, 2004/05/19 12:53:09
10    !  +1 Transformee directe      ! Author: P. Le Van
11    ! -1 Transformee inverse      ! Objet : filtre matriciel longitudinal, avec les matrices précalculées
12    ! +2 Filtre directe      ! pour l'opérateur filtre.
13    ! -2 Filtre inverse  
14    ! Variable Intensive      USE dimens_m, ONLY : iim, jjm
15    ! ifiltre = 1 filtre directe      USE parafilt, ONLY: matriceun, matriceus, matricevn, matricevs, matrinvn, &
16    ! ifiltre =-1 filtre inverse           matrinvs
17    ! Variable Extensive      USE coefils, ONLY : jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, &
18    ! ifiltre = 2 filtre directe           unsddu, unsddv
19    ! ifiltre =-2 filtre inverse  
20        INTEGER, intent(in):: nlat ! nombre de latitudes a filtrer
21    integer, intent(in):: iaire      integer, intent(in):: nbniv ! nombre de niveaux verticaux a filtrer
22    !  1 si champ intensif  
23    ! 2 si champ extensif (pondere par les aires)      REAL, intent(inout):: champ(iim + 1, nlat, nbniv)
24        ! en entrée : champ à filtrer, en sortie : champ filtré
25    integer, intent(in):: iter  
26    !  1 filtre simple      integer, intent(in):: ifiltre
27        !  +1 Transformee directe
28    LOGICAL, intent(in):: griscal      ! -1 Transformee inverse
29        ! +2 Filtre directe
30    ! Variables local to the procedure:      ! -2 Filtre inverse
31        ! Variable Intensive
32    INTEGER jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil      ! ifiltre = 1 filtre directe
33    INTEGER i, j, l, k      ! ifiltre =-1 filtre inverse
34    REAL matriceun, matriceus, matricevn, matricevs, matrinvn, matrinvs      ! Variable Extensive
35    COMMON /matrfil/matriceun(iim, iim, nfilun), matriceus(iim, iim, nfilus), &      ! ifiltre = 2 filtre directe
36         matricevn(iim, iim, nfilvn), matricevs(iim, iim, nfilvs), &      ! ifiltre =-2 filtre inverse
37         matrinvn(iim, iim, nfilun), matrinvs(iim, iim, nfilus)  
38    REAL eignq(iim), sdd1(iim), sdd2(iim)      integer, intent(in):: iaire
39    INTEGER hemisph      !  1 si champ intensif
40        ! 2 si champ extensif (pondere par les aires)
41    !-----------------------------------------------------------  
42        integer, intent(in):: iter
43    IF (ifiltre==1 .OR. ifiltre==-1) STOP &      !  1 filtre simple
44         'Pas de transformee simple dans cette version'  
45        LOGICAL, intent(in):: griscal
46    IF (iter==2) THEN  
47       PRINT *, ' Pas d iteration du filtre dans cette version !', &      ! Variables local to the procedure:
48            ' Utiliser old_filtreg et repasser !'  
49       STOP      INTEGER jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
50    END IF      INTEGER i, j, l, k
51        REAL eignq(iim), sdd1(iim), sdd2(iim)
52    IF (ifiltre==-2 .AND. .NOT. griscal) THEN      INTEGER hemisph
53       PRINT *, ' Cette routine ne calcule le filtre inverse que ', &  
54            ' sur la grille des scalaires !'      !-----------------------------------------------------------
55       STOP  
56    END IF      IF (ifiltre==1 .OR. ifiltre==-1) STOP &
57             'Pas de transformee simple dans cette version'
58    IF (ifiltre/=2 .AND. ifiltre/=-2) THEN  
59       PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &      IF (iter==2) THEN
60            ' corriger et repasser !'         PRINT *, ' Pas d iteration du filtre dans cette version !', &
61       STOP              ' Utiliser old_filtreg et repasser !'
62    END IF         STOP
63        END IF
64    IF (griscal) THEN  
65       IF (nlat/=jjp1) THEN      IF (ifiltre==-2 .AND. .NOT. griscal) THEN
66          PRINT 1111         PRINT *, ' Cette routine ne calcule le filtre inverse que ', &
67          STOP              ' sur la grille des scalaires !'
68       ELSE         STOP
69        END IF
70          IF (iaire==1) THEN  
71             CALL scopy(iim, sddv, 1, sdd1, 1)      IF (ifiltre/=2 .AND. ifiltre/=-2) THEN
72             CALL scopy(iim, unsddv, 1, sdd2, 1)         PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2', &
73          ELSE              ' corriger et repasser !'
74             CALL scopy(iim, unsddv, 1, sdd1, 1)         STOP
75             CALL scopy(iim, sddv, 1, sdd2, 1)      END IF
76          END IF  
77        IF (griscal) THEN
78          jdfil1 = 2         IF (nlat /= jjm + 1) THEN
79          jffil1 = jfiltnu            PRINT 1111
80          jdfil2 = jfiltsu            STOP
81          jffil2 = jjm         ELSE
82       END IF  
83    ELSE            IF (iaire==1) THEN
84       IF (nlat/=jjm) THEN               sdd1 = sddv
85          PRINT 2222               sdd2 = unsddv
86          STOP            ELSE
87       ELSE               sdd1 = unsddv
88                 sdd2 = sddv
89          IF (iaire==1) THEN            END IF
90             CALL scopy(iim, sddu, 1, sdd1, 1)  
91             CALL scopy(iim, unsddu, 1, sdd2, 1)            jdfil1 = 2
92          ELSE            jffil1 = jfiltnu
93             CALL scopy(iim, unsddu, 1, sdd1, 1)            jdfil2 = jfiltsu
94             CALL scopy(iim, sddu, 1, sdd2, 1)            jffil2 = jjm
95          END IF         END IF
96        ELSE
97          jdfil1 = 1         IF (nlat/=jjm) THEN
98          jffil1 = jfiltnv            PRINT 2222
99          jdfil2 = jfiltsv            STOP
100          jffil2 = jjm         ELSE
101       END IF  
102    END IF            IF (iaire==1) THEN
103                 sdd1 = sddu
104                 sdd2 = unsddu
105    DO hemisph = 1, 2            ELSE
106                 sdd1 = unsddu
107       IF (hemisph==1) THEN               sdd2 = sddu
108          jdfil = jdfil1            END IF
109          jffil = jffil1  
110       ELSE            jdfil1 = 1
111          jdfil = jdfil2            jffil1 = jfiltnv
112          jffil = jffil2            jdfil2 = jfiltsv
113       END IF            jffil2 = jjm
114           END IF
115        END IF
116       DO l = 1, nbniv  
117          DO j = jdfil, jffil  
118        DO hemisph = 1, 2
119    
120             DO i = 1, iim         IF (hemisph==1) THEN
121                champ(i, j, l) = champ(i, j, l)*sdd1(i)            jdfil = jdfil1
122             END DO            jffil = jffil1
123           ELSE
124              jdfil = jdfil2
125             IF (hemisph==1) THEN            jffil = jffil2
126           END IF
127                IF (ifiltre==-2) THEN  
128                   DO k = 1, iim  
129                      eignq(k) = 0.0         DO l = 1, nbniv
130                   END DO            DO j = jdfil, jffil
131                   DO k = 1, iim  
132                      DO i = 1, iim  
133                         eignq(k) = eignq(k) + matrinvn(k, i, j)*champ(i, j, l)               DO i = 1, iim
134                      END DO                  champ(i, j, l) = champ(i, j, l)*sdd1(i)
135                   END DO               END DO
136                ELSE IF (griscal) THEN  
137                   DO k = 1, iim  
138                      eignq(k) = 0.0               IF (hemisph==1) THEN
139                   END DO  
140                   DO i = 1, iim                  IF (ifiltre==-2) THEN
141                      DO k = 1, iim                     DO k = 1, iim
142                         eignq(k) = eignq(k) + matriceun(k, i, j)*champ(i, j, l)                        eignq(k) = 0.0
143                      END DO                     END DO
144                   END DO                     DO k = 1, iim
145                ELSE                        DO i = 1, iim
146                   DO k = 1, iim                           eignq(k) = eignq(k) + matrinvn(k, i, j)*champ(i, j, l)
147                      eignq(k) = 0.0                        END DO
148                   END DO                     END DO
149                   DO i = 1, iim                  ELSE IF (griscal) THEN
150                      DO k = 1, iim                     DO k = 1, iim
151                         eignq(k) = eignq(k) + matricevn(k, i, j)*champ(i, j, l)                        eignq(k) = 0.0
152                      END DO                     END DO
153                   END DO                     DO i = 1, iim
154                END IF                        DO k = 1, iim
155                             eignq(k) = eignq(k) + matriceun(k, i, j) &
156             ELSE                                * champ(i, j, l)
157                          END DO
158                IF (ifiltre==-2) THEN                     END DO
159                   DO k = 1, iim                  ELSE
160                      eignq(k) = 0.0                     DO k = 1, iim
161                   END DO                        eignq(k) = 0.0
162                   DO i = 1, iim                     END DO
163                      DO k = 1, iim                     DO i = 1, iim
164                         eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1)*champ(i, j, &                        DO k = 1, iim
165                              l)                           eignq(k) = eignq(k) + matricevn(k, i, j) &
166                      END DO                                * champ(i, j, l)
167                   END DO                        END DO
168                ELSE IF (griscal) THEN                     END DO
169                   DO k = 1, iim                  END IF
170                      eignq(k) = 0.0  
171                   END DO               ELSE
172                   DO i = 1, iim  
173                      DO k = 1, iim                  IF (ifiltre==-2) THEN
174                         eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1)*champ(i, j &                     DO k = 1, iim
175                              , l)                        eignq(k) = 0.0
176                      END DO                     END DO
177                   END DO                     DO i = 1, iim
178                ELSE                        DO k = 1, iim
179                   DO k = 1, iim                           eignq(k) = eignq(k) + matrinvs(k, i, j-jfiltsu+1) &
180                      eignq(k) = 0.0                                *champ(i, j, l)
181                   END DO                        END DO
182                   DO i = 1, iim                     END DO
183                      DO k = 1, iim                  ELSE IF (griscal) THEN
184                         eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1)*champ(i, j &                     DO k = 1, iim
185                              , l)                        eignq(k) = 0.0
186                      END DO                     END DO
187                   END DO                     DO i = 1, iim
188                END IF                        DO k = 1, iim
189                             eignq(k) = eignq(k) + matriceus(k, i, j-jfiltsu+1) &
190             END IF                                *champ(i, j , l)
191                          END DO
192             IF (ifiltre==2) THEN                     END DO
193                DO i = 1, iim                  ELSE
194                   champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)                     DO k = 1, iim
195                end DO                        eignq(k) = 0.0
196             ELSE                     END DO
197                DO i = 1, iim                     DO i = 1, iim
198                   champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)                        DO k = 1, iim
199                end DO                           eignq(k) = eignq(k) + matricevs(k, i, j-jfiltsv+1) &
200             END IF                                *champ(i, j , l)
201                          END DO
202                       END DO
203                    END IF
204    
205                 END IF
206    
207                 IF (ifiltre==2) THEN
208                    DO i = 1, iim
209                       champ(i, j, l) = (champ(i, j, l)+eignq(i))*sdd2(i)
210                    end DO
211                 ELSE
212                    DO i = 1, iim
213                       champ(i, j, l) = (champ(i, j, l)-eignq(i))*sdd2(i)
214                    end DO
215                 END IF
216    
217             champ(iip1, j, l) = champ(1, j, l)               champ(iim + 1, j, l) = champ(1, j, l)
218    
219          END DO            END DO
220    
221       END DO         END DO
222    
223    end DO      end DO
224    
225  1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &  1111 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
226         & CHAMP a filtrer, sur la grille des scalaires'/)           & CHAMP a filtrer, sur la grille des scalaires'/)
227  2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &  2222 FORMAT (//20X, 'ERREUR dans le dimensionnement du tableau &
228         &CHAMP a filtrer, sur la grille de V ou de Z'/)           &CHAMP a filtrer, sur la grille de V ou de Z'/)
229    
230      END SUBROUTINE filtreg
231    
232  END SUBROUTINE filtreg  end module filtreg_m
Legend:
Removed from v.25  
changed lines
  Added in v.37
  ViewVC Help
Powered by ViewVC 1.1.21