/[lmdze]/trunk/libf/filtrez/filtreg.f90
ViewVC logotype

Diff of /trunk/libf/filtrez/filtreg.f90

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

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