source: codes/icosagcm/trunk/src/wind.f90 @ 78

Last change on this file since 78 was 49, checked in by dubos, 12 years ago

Bugfix in wind reconstruction on hexagons
File size: 8.2 KB
Line 
1MODULE wind_mod
2
3CONTAINS
4
5
6 
7  SUBROUTINE compute_wind_centered(ue,ucenter)
8  USE icosa
9 
10  IMPLICIT NONE
11  REAL(rstd) :: ue(3*iim*jjm,llm)
12  REAL(rstd) :: ucenter(iim*jjm,3,llm)
13  INTEGER :: i,j,ij,l   
14 
15    DO l=1,llm
16      DO j=jj_begin,jj_end
17        DO i=ii_begin,ii_end
18          ij=(j-1)*iim+i
19          ucenter(ij,:,l)=1/Ai(ij)*                                                                                                &
20                        ( ne(ij,right)*ue(ij+u_right,l)*le(ij+u_right)*((xyz_v(ij+z_rdown,:)+xyz_v(ij+z_rup,:))/2-centroid(ij,:))  &
21                         + ne(ij,rup)*ue(ij+u_rup,l)*le(ij+u_rup)*((xyz_v(ij+z_rup,:)+xyz_v(ij+z_up,:))/2-centroid(ij,:))          &
22                         + ne(ij,lup)*ue(ij+u_lup,l)*le(ij+u_lup)*((xyz_v(ij+z_up,:)+xyz_v(ij+z_lup,:))/2-centroid(ij,:))          &
23                         + ne(ij,left)*ue(ij+u_left,l)*le(ij+u_left)*((xyz_v(ij+z_lup,:)+xyz_v(ij+z_ldown,:))/2-centroid(ij,:))    &
24                         + ne(ij,ldown)*ue(ij+u_ldown,l)*le(ij+u_ldown)*((xyz_v(ij+z_ldown,:)+xyz_v(ij+z_down,:))/2-centroid(ij,:))&
25                         + ne(ij,rdown)*ue(ij+u_rdown,l)*le(ij+u_rdown)*((xyz_v(ij+z_down,:)+xyz_v(ij+z_rdown,:))/2-centroid(ij,:)))
26        ENDDO
27      ENDDO
28    ENDDO
29 
30 END SUBROUTINE compute_wind_centered
31 
32 
33 SUBROUTINE compute_wind_on_edge(ue,uedge)
34  USE icosa
35   
36  IMPLICIT NONE
37  REAL(rstd) :: ue(3*iim*jjm,llm)
38  REAL(rstd) :: uedge(3*iim*jjm,3,llm)
39
40  REAL(rstd) :: ut(3*iim*jjm,llm)
41  INTEGER :: i,j,ij,l     
42   
43    CALL compute_tangential_compound(ue,ut)
44 
45    DO l=1,llm
46      DO j=jj_begin,jj_end
47        DO i=ii_begin,ii_end
48          ij=(j-1)*iim+i
49          uedge(ij+u_right,:,l)=ue(ij+u_right,l)*ep_e(ij+u_right,:)*ne(ij,right) + ut(ij+u_right,l)*et_e(ij+u_right,:)*ne(ij,right) 
50          uedge(ij+u_lup,:,l)=ue(ij+u_lup,l)*ep_e(ij+u_lup,:)*ne(ij,lup) + ut(ij+u_lup,l)*et_e(ij+u_lup,:)*ne(ij,lup)
51          uedge(ij+u_ldown,:,l)=ue(ij+u_ldown,l)*ep_e(ij+u_ldown,:)*ne(ij,ldown) + ut(ij+u_ldown,l)*et_e(ij+u_ldown,:)*ne(ij,ldown)
52        ENDDO
53      ENDDO
54    ENDDO
55 
56 END SUBROUTINE compute_wind_on_edge
57 
58 
59 
60 SUBROUTINE compute_tangential_compound(ue,ut)
61  USE icosa 
62  IMPLICIT NONE
63  REAL(rstd) :: ue(3*iim*jjm,llm)
64  REAL(rstd) :: ut(3*iim*jjm,llm)
65  INTEGER :: i,j,l,ij
66   
67  DO l=1,llm
68    DO j=jj_begin,jj_end
69      DO i=ii_begin,ii_end
70        ij=(j-1)*iim+i
71   
72        ut(ij+u_right,l) = 1/de(ij+u_right) *                                            & 
73                         ( wee(ij+u_right,1,1)*ue(ij+u_rup,l)+                           &
74                           wee(ij+u_right,2,1)*ue(ij+u_lup,l)+                           &
75                           wee(ij+u_right,3,1)*ue(ij+u_left,l)+                          &
76                           wee(ij+u_right,4,1)*ue(ij+u_ldown,l)+                         &
77                           wee(ij+u_right,5,1)*ue(ij+u_rdown,l)+                         & 
78                           wee(ij+u_right,1,2)*ue(ij+t_right+u_ldown,l)+                 &
79                           wee(ij+u_right,2,2)*ue(ij+t_right+u_rdown,l)+                 &
80                           wee(ij+u_right,3,2)*ue(ij+t_right+u_right,l)+                 &
81                           wee(ij+u_right,4,2)*ue(ij+t_right+u_rup,l)+                   &
82                           wee(ij+u_right,5,2)*ue(ij+t_right+u_lup,l) )   
83     
84        ut(ij+u_lup,l) =  1/de(ij+u_lup) *                                           & 
85                         ( wee(ij+u_lup,1,1)*ue(ij+u_left,l)+                        &
86                           wee(ij+u_lup,2,1)*ue(ij+u_ldown,l)+                       &
87                           wee(ij+u_lup,3,1)*ue(ij+u_rdown,l)+                       &
88                           wee(ij+u_lup,4,1)*ue(ij+u_right,l)+                       &
89                           wee(ij+u_lup,5,1)*ue(ij+u_rup,l)+                         & 
90                           wee(ij+u_lup,1,2)*ue(ij+t_lup+u_right,l)+                 &
91                           wee(ij+u_lup,2,2)*ue(ij+t_lup+u_rup,l)+                   &
92                           wee(ij+u_lup,3,2)*ue(ij+t_lup+u_lup,l)+                   &
93                           wee(ij+u_lup,4,2)*ue(ij+t_lup+u_left,l)+                  &
94                           wee(ij+u_lup,5,2)*ue(ij+t_lup+u_ldown,l) )
95
96   
97        ut(ij+u_ldown,l) = 1/de(ij+u_ldown) *   & 
98                         ( wee(ij+u_ldown,1,1)*ue(ij+u_rdown,l)+                      &
99                           wee(ij+u_ldown,2,1)*ue(ij+u_right,l)+                      &
100                           wee(ij+u_ldown,3,1)*ue(ij+u_rup,l)+                        &
101                           wee(ij+u_ldown,4,1)*ue(ij+u_lup,l)+                        &
102                           wee(ij+u_ldown,5,1)*ue(ij+u_left,l)+                       & 
103                           wee(ij+u_ldown,1,2)*ue(ij+t_ldown+u_lup,l)+                &
104                           wee(ij+u_ldown,2,2)*ue(ij+t_ldown+u_left,l)+               &
105                           wee(ij+u_ldown,3,2)*ue(ij+t_ldown+u_ldown,l)+              &
106                           wee(ij+u_ldown,4,2)*ue(ij+t_ldown+u_rdown,l)+              &
107                           wee(ij+u_ldown,5,2)*ue(ij+t_ldown+u_right,l) ) 
108       
109        ENDDO
110      ENDDO
111    ENDDO
112                       
113 END SUBROUTINE compute_tangential_compound
114 
115 SUBROUTINE compute_wind_lonlat_compound(u, ulon, ulat)
116  USE icosa 
117   
118  IMPLICIT NONE
119  REAL(rstd) :: u(3*iim*jjm,3,llm)
120  REAL(rstd) :: ulon(3*iim*jjm,3,llm)
121  REAL(rstd) :: ulat(3*iim*jjm,3,llm)
122
123  INTEGER :: i,j,ij,l     
124   
125 
126    DO l=1,llm
127      DO j=jj_begin-1,jj_end+1
128        DO i=ii_begin-1,ii_end+1
129          ij=(j-1)*iim+i
130          ulon(ij+u_right,:,l)=sum(u(ij+u_right,:,l)*elon_e(ij+u_right,:))*elon_e(ij+u_right,:) 
131          ulon(ij+u_lup,:,l)=sum(u(ij+u_lup,:,l)*elon_e(ij+u_lup,:))*elon_e(ij+u_lup,:)
132          ulon(ij+u_ldown,:,l)=sum(u(ij+u_ldown,:,l)*elon_e(ij+u_ldown,:))*elon_e(ij+u_ldown,:)
133         
134          ulat(ij+u_right,:,l)=sum(u(ij+u_right,:,l)*elat_e(ij+u_right,:))*elat_e(ij+u_right,:) 
135          ulat(ij+u_lup,:,l)=sum(u(ij+u_lup,:,l)*elat_e(ij+u_lup,:))*elat_e(ij+u_lup,:) 
136          ulat(ij+u_ldown,:,l)=sum(u(ij+u_ldown,:,l)*elat_e(ij+u_ldown,:))*elat_e(ij+u_ldown,:) 
137         
138        ENDDO
139      ENDDO
140    ENDDO
141 
142 END SUBROUTINE compute_wind_lonlat_compound
143 
144  SUBROUTINE compute_wind_from_lonlat_compound(ulon, ulat, u)
145  USE icosa 
146   
147  IMPLICIT NONE
148  REAL(rstd) :: u(3*iim*jjm,3,llm)
149  REAL(rstd) :: ulon(3*iim*jjm,llm)
150  REAL(rstd) :: ulat(3*iim*jjm,llm)
151
152  INTEGER :: i,j,ij,l     
153 
154    DO l=1,llm
155      DO j=jj_begin-1,jj_end+1
156        DO i=ii_begin-1,ii_end+1
157          ij=(j-1)*iim+i
158          u(ij+u_right,:,l)=ulon(ij+u_right,l)*elon_e(ij+u_right,:)+ ulat(ij+u_right,l)*elat_e(ij+u_right,:)
159          u(ij+u_lup,:,l)=ulon(ij+u_lup,l)*elon_e(ij+u_lup,:) + ulat(ij+u_lup,l)*elat_e(ij+u_lup,:)
160          u(ij+u_ldown,:,l)=ulon(ij+u_ldown,l)*elon_e(ij+u_ldown,:) + ulat(ij+u_ldown,l)*elat_e(ij+u_ldown,:)
161        ENDDO
162      ENDDO
163    ENDDO
164 
165  END SUBROUTINE compute_wind_from_lonlat_compound
166 
167  SUBROUTINE compute_wind_perp_from_lonlat_compound(ulon, ulat, up)
168  USE icosa 
169   
170  IMPLICIT NONE
171  REAL(rstd) :: up(3*iim*jjm,llm)
172  REAL(rstd) :: ulon(3*iim*jjm,llm)
173  REAL(rstd) :: ulat(3*iim*jjm,llm)
174  REAL(rstd) :: u(3*iim*jjm,3,llm)
175
176  INTEGER :: i,j,ij,l     
177 
178   CALL compute_wind_from_lonlat_compound(ulon, ulat, u)
179
180    DO l=1,llm
181      DO j=jj_begin-1,jj_end+1
182        DO i=ii_begin-1,ii_end+1
183          ij=(j-1)*iim+i
184          up(ij+u_right,l)=sum(u(ij+u_right,:,l)*ep_e(ij+u_right,:))
185          up(ij+u_lup,l)=sum(u(ij+u_lup,:,l)*ep_e(ij+u_lup,:))
186          up(ij+u_ldown,l)=sum(u(ij+u_ldown,:,l)*ep_e(ij+u_ldown,:))
187        ENDDO
188      ENDDO
189    ENDDO
190 
191  END SUBROUTINE compute_wind_perp_from_lonlat_compound
192   
193 SUBROUTINE compute_wind_centered_lonlat_compound(uc, ulon, ulat)
194  USE icosa 
195   
196  IMPLICIT NONE
197  REAL(rstd) :: uc(iim*jjm,3,llm)
198  REAL(rstd) :: ulon(iim*jjm,llm)
199  REAL(rstd) :: ulat(iim*jjm,llm)
200
201  INTEGER :: i,j,ij,l     
202   
203 
204    DO l=1,llm
205      DO j=jj_begin,jj_end
206        DO i=ii_begin,ii_end
207          ij=(j-1)*iim+i
208          ulon(ij,l)=sum(uc(ij,:,l)*elon_i(ij,:))
209          ulat(ij,l)=sum(uc(ij,:,l)*elat_i(ij,:)) 
210        ENDDO
211      ENDDO
212    ENDDO
213 
214 END SUBROUTINE compute_wind_centered_lonlat_compound
215
216
217END MODULE wind_mod
Note: See TracBrowser for help on using the repository browser.