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

Last change on this file since 200 was 196, checked in by dubos, 10 years ago

First draft of generic dynamics-physics interface - works with DCMIP5.1
File size: 11.0 KB
Line 
1MODULE wind_mod
2
3CONTAINS
4
5  SUBROUTINE un2ulonlat(f_u, f_ulon, f_ulat)
6  USE icosa
7  IMPLICIT NONE
8    TYPE(t_field), POINTER :: f_u(:) ! IN  : normal velocity components on edges
9    TYPE(t_field), POINTER :: f_ulon(:), f_ulat(:) ! OUT : velocity reconstructed at hexagons
10   
11    REAL(rstd),POINTER :: u(:,:),  ulon(:,:), ulat(:,:)
12    INTEGER :: ind
13
14    DO ind=1,ndomain
15       IF (.NOT. assigned_domain(ind)) CYCLE
16       CALL swap_dimensions(ind)
17       CALL swap_geometry(ind)
18       u=f_u(ind)
19       ulon=f_ulon(ind)
20       ulat=f_ulat(ind)
21       CALL compute_un2ulonlat(u,ulon, ulat)
22    END DO
23
24  END SUBROUTINE un2ulonlat
25
26 
27  SUBROUTINE compute_wind_centered(ue,ucenter)
28  USE icosa
29 
30  IMPLICIT NONE
31  REAL(rstd) :: ue(3*iim*jjm,llm)
32  REAL(rstd) :: ucenter(iim*jjm,3,llm)
33  INTEGER :: i,j,ij,l   
34 
35    DO l=1,llm
36      DO j=jj_begin,jj_end
37        DO i=ii_begin,ii_end
38          ij=(j-1)*iim+i
39          ucenter(ij,:,l)=1/Ai(ij)*                                                                                                &
40                        ( 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,:))  &
41                         + 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,:))          &
42                         + 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,:))          &
43                         + 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,:))    &
44                         + 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,:))&
45                         + 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,:)))
46        ENDDO
47      ENDDO
48    ENDDO
49 
50 END SUBROUTINE compute_wind_centered
51 
52 
53 SUBROUTINE compute_wind_on_edge(ue,uedge)
54  USE icosa
55   
56  IMPLICIT NONE
57  REAL(rstd) :: ue(3*iim*jjm,llm)
58  REAL(rstd) :: uedge(3*iim*jjm,3,llm)
59
60  REAL(rstd) :: ut(3*iim*jjm,llm)
61  INTEGER :: i,j,ij,l     
62   
63    CALL compute_tangential_compound(ue,ut)
64 
65    DO l=1,llm
66      DO j=jj_begin,jj_end
67        DO i=ii_begin,ii_end
68          ij=(j-1)*iim+i
69          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) 
70          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)
71          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)
72        ENDDO
73      ENDDO
74    ENDDO
75 
76 END SUBROUTINE compute_wind_on_edge
77 
78 
79 
80 SUBROUTINE compute_tangential_compound(ue,ut)
81  USE icosa 
82  IMPLICIT NONE
83  REAL(rstd) :: ue(3*iim*jjm,llm)
84  REAL(rstd) :: ut(3*iim*jjm,llm)
85  INTEGER :: i,j,l,ij
86   
87  DO l=1,llm
88    DO j=jj_begin,jj_end
89      DO i=ii_begin,ii_end
90        ij=(j-1)*iim+i
91   
92        ut(ij+u_right,l) = 1/de(ij+u_right) *                                            & 
93                         ( wee(ij+u_right,1,1)*ue(ij+u_rup,l)+                           &
94                           wee(ij+u_right,2,1)*ue(ij+u_lup,l)+                           &
95                           wee(ij+u_right,3,1)*ue(ij+u_left,l)+                          &
96                           wee(ij+u_right,4,1)*ue(ij+u_ldown,l)+                         &
97                           wee(ij+u_right,5,1)*ue(ij+u_rdown,l)+                         & 
98                           wee(ij+u_right,1,2)*ue(ij+t_right+u_ldown,l)+                 &
99                           wee(ij+u_right,2,2)*ue(ij+t_right+u_rdown,l)+                 &
100                           wee(ij+u_right,3,2)*ue(ij+t_right+u_right,l)+                 &
101                           wee(ij+u_right,4,2)*ue(ij+t_right+u_rup,l)+                   &
102                           wee(ij+u_right,5,2)*ue(ij+t_right+u_lup,l) )   
103     
104        ut(ij+u_lup,l) =  1/de(ij+u_lup) *                                           & 
105                         ( wee(ij+u_lup,1,1)*ue(ij+u_left,l)+                        &
106                           wee(ij+u_lup,2,1)*ue(ij+u_ldown,l)+                       &
107                           wee(ij+u_lup,3,1)*ue(ij+u_rdown,l)+                       &
108                           wee(ij+u_lup,4,1)*ue(ij+u_right,l)+                       &
109                           wee(ij+u_lup,5,1)*ue(ij+u_rup,l)+                         & 
110                           wee(ij+u_lup,1,2)*ue(ij+t_lup+u_right,l)+                 &
111                           wee(ij+u_lup,2,2)*ue(ij+t_lup+u_rup,l)+                   &
112                           wee(ij+u_lup,3,2)*ue(ij+t_lup+u_lup,l)+                   &
113                           wee(ij+u_lup,4,2)*ue(ij+t_lup+u_left,l)+                  &
114                           wee(ij+u_lup,5,2)*ue(ij+t_lup+u_ldown,l) )
115
116   
117        ut(ij+u_ldown,l) = 1/de(ij+u_ldown) *   & 
118                         ( wee(ij+u_ldown,1,1)*ue(ij+u_rdown,l)+                      &
119                           wee(ij+u_ldown,2,1)*ue(ij+u_right,l)+                      &
120                           wee(ij+u_ldown,3,1)*ue(ij+u_rup,l)+                        &
121                           wee(ij+u_ldown,4,1)*ue(ij+u_lup,l)+                        &
122                           wee(ij+u_ldown,5,1)*ue(ij+u_left,l)+                       & 
123                           wee(ij+u_ldown,1,2)*ue(ij+t_ldown+u_lup,l)+                &
124                           wee(ij+u_ldown,2,2)*ue(ij+t_ldown+u_left,l)+               &
125                           wee(ij+u_ldown,3,2)*ue(ij+t_ldown+u_ldown,l)+              &
126                           wee(ij+u_ldown,4,2)*ue(ij+t_ldown+u_rdown,l)+              &
127                           wee(ij+u_ldown,5,2)*ue(ij+t_ldown+u_right,l) ) 
128       
129        ENDDO
130      ENDDO
131    ENDDO
132                       
133 END SUBROUTINE compute_tangential_compound
134 
135 SUBROUTINE compute_wind_lonlat_compound(u, ulon, ulat)
136  USE icosa 
137   
138  IMPLICIT NONE
139  REAL(rstd) :: u(3*iim*jjm,3,llm)
140  REAL(rstd) :: ulon(3*iim*jjm,3,llm)
141  REAL(rstd) :: ulat(3*iim*jjm,3,llm)
142
143  INTEGER :: i,j,ij,l     
144   
145 
146    DO l=1,llm
147      DO j=jj_begin-1,jj_end+1
148        DO i=ii_begin-1,ii_end+1
149          ij=(j-1)*iim+i
150          ulon(ij+u_right,:,l)=sum(u(ij+u_right,:,l)*elon_e(ij+u_right,:))*elon_e(ij+u_right,:) 
151          ulon(ij+u_lup,:,l)=sum(u(ij+u_lup,:,l)*elon_e(ij+u_lup,:))*elon_e(ij+u_lup,:)
152          ulon(ij+u_ldown,:,l)=sum(u(ij+u_ldown,:,l)*elon_e(ij+u_ldown,:))*elon_e(ij+u_ldown,:)
153         
154          ulat(ij+u_right,:,l)=sum(u(ij+u_right,:,l)*elat_e(ij+u_right,:))*elat_e(ij+u_right,:) 
155          ulat(ij+u_lup,:,l)=sum(u(ij+u_lup,:,l)*elat_e(ij+u_lup,:))*elat_e(ij+u_lup,:) 
156          ulat(ij+u_ldown,:,l)=sum(u(ij+u_ldown,:,l)*elat_e(ij+u_ldown,:))*elat_e(ij+u_ldown,:) 
157         
158        ENDDO
159      ENDDO
160    ENDDO
161 
162 END SUBROUTINE compute_wind_lonlat_compound
163 
164  SUBROUTINE compute_wind_from_lonlat_compound(ulon, ulat, u)
165  USE icosa 
166   
167  IMPLICIT NONE
168  REAL(rstd) :: u(3*iim*jjm,3,llm)
169  REAL(rstd) :: ulon(3*iim*jjm,llm)
170  REAL(rstd) :: ulat(3*iim*jjm,llm)
171
172  INTEGER :: i,j,ij,l     
173 
174    DO l=1,llm
175      DO j=jj_begin-1,jj_end+1
176        DO i=ii_begin-1,ii_end+1
177          ij=(j-1)*iim+i
178          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,:)
179          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,:)
180          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,:)
181        ENDDO
182      ENDDO
183    ENDDO
184 
185  END SUBROUTINE compute_wind_from_lonlat_compound
186 
187  SUBROUTINE compute_wind_centered_from_lonlat_compound(ulon, ulat, u)
188  USE icosa 
189   
190  IMPLICIT NONE
191  REAL(rstd) :: u(iim*jjm,3,llm)
192  REAL(rstd) :: ulon(iim*jjm,llm)
193  REAL(rstd) :: ulat(iim*jjm,llm)
194
195  INTEGER :: i,j,ij,l     
196  DO l=1,llm
197      DO j=jj_begin-1,jj_end+1
198        DO i=ii_begin-1,ii_end+1
199          ij=(j-1)*iim+i
200          u(ij,:,l)=ulon(ij,l)*elon_i(ij,:)+ ulat(ij,l)*elat_i(ij,:)
201        ENDDO
202      ENDDO
203    ENDDO
204 
205  END SUBROUTINE compute_wind_centered_from_lonlat_compound
206 
207  SUBROUTINE compute_wind2D_from_lonlat_compound(ulon, ulat, u)
208  USE icosa 
209 
210  IMPLICIT NONE
211  REAL(rstd) :: u(3*iim*jjm,3)
212  REAL(rstd) :: ulon(3*iim*jjm)
213  REAL(rstd) :: ulat(3*iim*jjm)
214 
215  INTEGER :: i,j,ij
216 
217  DO j=jj_begin-1,jj_end+1
218     DO i=ii_begin-1,ii_end+1
219        ij=(j-1)*iim+i
220        u(ij+u_right,:)=ulon(ij+u_right)*elon_e(ij+u_right,:)+ ulat(ij+u_right)*elat_e(ij+u_right,:)
221        u(ij+u_lup,:)=ulon(ij+u_lup)*elon_e(ij+u_lup,:) + ulat(ij+u_lup)*elat_e(ij+u_lup,:)
222        u(ij+u_ldown,:)=ulon(ij+u_ldown)*elon_e(ij+u_ldown,:) + ulat(ij+u_ldown)*elat_e(ij+u_ldown,:)
223     ENDDO
224  ENDDO
225   
226  END SUBROUTINE compute_wind2D_from_lonlat_compound
227 
228  SUBROUTINE compute_wind_perp_from_lonlat_compound(ulon, ulat, up)
229  USE icosa 
230   
231  IMPLICIT NONE
232  REAL(rstd) :: up(3*iim*jjm,llm)
233  REAL(rstd) :: ulon(3*iim*jjm,llm)
234  REAL(rstd) :: ulat(3*iim*jjm,llm)
235  REAL(rstd) :: u(3*iim*jjm,3,llm)
236
237  INTEGER :: i,j,ij,l     
238 
239   CALL compute_wind_from_lonlat_compound(ulon, ulat, u)
240
241    DO l=1,llm
242      DO j=jj_begin-1,jj_end+1
243        DO i=ii_begin-1,ii_end+1
244          ij=(j-1)*iim+i
245          up(ij+u_right,l)=sum(u(ij+u_right,:,l)*ep_e(ij+u_right,:))
246          up(ij+u_lup,l)=sum(u(ij+u_lup,:,l)*ep_e(ij+u_lup,:))
247          up(ij+u_ldown,l)=sum(u(ij+u_ldown,:,l)*ep_e(ij+u_ldown,:))
248        ENDDO
249      ENDDO
250    ENDDO
251 
252  END SUBROUTINE compute_wind_perp_from_lonlat_compound
253   
254  SUBROUTINE compute_wind2D_perp_from_lonlat_compound(ulon, ulat, up)
255  USE icosa 
256   
257  IMPLICIT NONE
258  REAL(rstd) :: up(3*iim*jjm)
259  REAL(rstd) :: ulon(3*iim*jjm)
260  REAL(rstd) :: ulat(3*iim*jjm)
261  REAL(rstd) :: u(3*iim*jjm,3)
262
263  INTEGER :: i,j,ij 
264 
265  CALL compute_wind2D_from_lonlat_compound(ulon, ulat, u)
266  DO j=jj_begin-1,jj_end+1
267     DO i=ii_begin-1,ii_end+1
268        ij=(j-1)*iim+i
269        up(ij+u_right)=sum(u(ij+u_right,:)*ep_e(ij+u_right,:))
270        up(ij+u_lup)=sum(u(ij+u_lup,:)*ep_e(ij+u_lup,:))
271        up(ij+u_ldown)=sum(u(ij+u_ldown,:)*ep_e(ij+u_ldown,:))
272     ENDDO
273  ENDDO
274   
275  END SUBROUTINE compute_wind2D_perp_from_lonlat_compound
276   
277 SUBROUTINE compute_wind_centered_lonlat_compound(uc, ulon, ulat)
278  USE icosa 
279   
280  IMPLICIT NONE
281  REAL(rstd) :: uc(iim*jjm,3,llm)
282  REAL(rstd) :: ulon(iim*jjm,llm)
283  REAL(rstd) :: ulat(iim*jjm,llm)
284
285  INTEGER :: i,j,ij,l     
286   
287 
288    DO l=1,llm
289      DO j=jj_begin,jj_end
290        DO i=ii_begin,ii_end
291          ij=(j-1)*iim+i
292          ulon(ij,l)=sum(uc(ij,:,l)*elon_i(ij,:))
293          ulat(ij,l)=sum(uc(ij,:,l)*elat_i(ij,:)) 
294        ENDDO
295      ENDDO
296    ENDDO
297 
298 END SUBROUTINE compute_wind_centered_lonlat_compound
299
300 SUBROUTINE compute_un2ulonlat(un, ulon, ulat)
301  USE icosa 
302   
303  IMPLICIT NONE
304  REAL(rstd),INTENT(IN)  :: un(3*iim*jjm,llm)
305  REAL(rstd),INTENT(OUT) :: ulon(iim*jjm,llm)
306  REAL(rstd),INTENT(OUT) :: ulat(iim*jjm,llm)
307
308  REAL(rstd)             :: uc(iim*jjm,3,llm)
309   
310  CALL compute_wind_centered(un,uc) 
311  CALL compute_wind_centered_lonlat_compound(uc, ulon, ulat)
312 
313 END SUBROUTINE compute_un2ulonlat
314
315END MODULE wind_mod
Note: See TracBrowser for help on using the repository browser.