/[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 30 by guez, Thu Apr 1 09:07:28 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                 sdd1 = sddv
89                 sdd2 = unsddv
90              ELSE
91                 sdd1 = unsddv
92                 sdd2 = sddv
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                 sdd1 = sddu
108                 sdd2 = unsddu
109              ELSE
110                 sdd1 = unsddu
111                 sdd2 = sddu
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.25  
changed lines
  Added in v.30
  ViewVC Help
Powered by ViewVC 1.1.21