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

Last change on this file since 294 was 266, checked in by ymipsl, 10 years ago

Synchronize trunk and Saturn branch.
Merge modification from Saturn branch to trunk

YM
File size: 13.2 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  SUBROUTINE ulonlat2un(f_ulon, f_ulat,f_u)
27  USE icosa
28  IMPLICIT NONE
29    TYPE(t_field), POINTER :: f_ulon(:), f_ulat(:) ! IN : velocity reconstructed at hexagons
30    TYPE(t_field), POINTER :: f_u(:) ! OUT  : normal velocity components on edges
31   
32    REAL(rstd),POINTER :: u(:,:),  ulon(:,:), ulat(:,:)
33    INTEGER :: ind
34
35    DO ind=1,ndomain
36       IF (.NOT. assigned_domain(ind)) CYCLE
37       CALL swap_dimensions(ind)
38       CALL swap_geometry(ind)
39       u=f_u(ind)
40       ulon=f_ulon(ind)
41       ulat=f_ulat(ind)
42       CALL compute_ulonlat2un(ulon, ulat,u)
43    END DO
44
45  END SUBROUTINE ulonlat2un
46 
47  SUBROUTINE compute_wind_centered(ue,ucenter)
48  USE icosa
49 
50  IMPLICIT NONE
51  REAL(rstd) :: ue(3*iim*jjm,llm)
52  REAL(rstd) :: ucenter(iim*jjm,3,llm)
53  INTEGER :: i,j,ij,l   
54 
55    DO l=1,llm
56      DO j=jj_begin,jj_end
57        DO i=ii_begin,ii_end
58          ij=(j-1)*iim+i
59          ucenter(ij,:,l)=1/Ai(ij)*                                                                                                &
60                        ( 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,:))  &
61                         + 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,:))          &
62                         + 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,:))          &
63                         + 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,:))    &
64                         + 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,:))&
65                         + 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,:)))
66        ENDDO
67      ENDDO
68    ENDDO
69 
70 END SUBROUTINE compute_wind_centered
71 
72 
73 SUBROUTINE compute_wind_on_edge(ue,uedge)
74  USE icosa
75   
76  IMPLICIT NONE
77  REAL(rstd) :: ue(3*iim*jjm,llm)
78  REAL(rstd) :: uedge(3*iim*jjm,3,llm)
79
80  REAL(rstd) :: ut(3*iim*jjm,llm)
81  INTEGER :: i,j,ij,l     
82   
83    CALL compute_tangential_compound(ue,ut)
84 
85    DO l=1,llm
86      DO j=jj_begin,jj_end
87        DO i=ii_begin,ii_end
88          ij=(j-1)*iim+i
89          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) 
90          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)
91          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)
92        ENDDO
93      ENDDO
94    ENDDO
95 
96 END SUBROUTINE compute_wind_on_edge
97 
98 
99 
100 SUBROUTINE compute_tangential_compound(ue,ut)
101  USE icosa 
102  IMPLICIT NONE
103  REAL(rstd) :: ue(3*iim*jjm,llm)
104  REAL(rstd) :: ut(3*iim*jjm,llm)
105  INTEGER :: i,j,l,ij
106   
107  DO l=1,llm
108    DO j=jj_begin,jj_end
109      DO i=ii_begin,ii_end
110        ij=(j-1)*iim+i
111   
112        ut(ij+u_right,l) = 1/de(ij+u_right) *                                            & 
113                         ( wee(ij+u_right,1,1)*ue(ij+u_rup,l)+                           &
114                           wee(ij+u_right,2,1)*ue(ij+u_lup,l)+                           &
115                           wee(ij+u_right,3,1)*ue(ij+u_left,l)+                          &
116                           wee(ij+u_right,4,1)*ue(ij+u_ldown,l)+                         &
117                           wee(ij+u_right,5,1)*ue(ij+u_rdown,l)+                         & 
118                           wee(ij+u_right,1,2)*ue(ij+t_right+u_ldown,l)+                 &
119                           wee(ij+u_right,2,2)*ue(ij+t_right+u_rdown,l)+                 &
120                           wee(ij+u_right,3,2)*ue(ij+t_right+u_right,l)+                 &
121                           wee(ij+u_right,4,2)*ue(ij+t_right+u_rup,l)+                   &
122                           wee(ij+u_right,5,2)*ue(ij+t_right+u_lup,l) )   
123     
124        ut(ij+u_lup,l) =  1/de(ij+u_lup) *                                           & 
125                         ( wee(ij+u_lup,1,1)*ue(ij+u_left,l)+                        &
126                           wee(ij+u_lup,2,1)*ue(ij+u_ldown,l)+                       &
127                           wee(ij+u_lup,3,1)*ue(ij+u_rdown,l)+                       &
128                           wee(ij+u_lup,4,1)*ue(ij+u_right,l)+                       &
129                           wee(ij+u_lup,5,1)*ue(ij+u_rup,l)+                         & 
130                           wee(ij+u_lup,1,2)*ue(ij+t_lup+u_right,l)+                 &
131                           wee(ij+u_lup,2,2)*ue(ij+t_lup+u_rup,l)+                   &
132                           wee(ij+u_lup,3,2)*ue(ij+t_lup+u_lup,l)+                   &
133                           wee(ij+u_lup,4,2)*ue(ij+t_lup+u_left,l)+                  &
134                           wee(ij+u_lup,5,2)*ue(ij+t_lup+u_ldown,l) )
135
136   
137        ut(ij+u_ldown,l) = 1/de(ij+u_ldown) *   & 
138                         ( wee(ij+u_ldown,1,1)*ue(ij+u_rdown,l)+                      &
139                           wee(ij+u_ldown,2,1)*ue(ij+u_right,l)+                      &
140                           wee(ij+u_ldown,3,1)*ue(ij+u_rup,l)+                        &
141                           wee(ij+u_ldown,4,1)*ue(ij+u_lup,l)+                        &
142                           wee(ij+u_ldown,5,1)*ue(ij+u_left,l)+                       & 
143                           wee(ij+u_ldown,1,2)*ue(ij+t_ldown+u_lup,l)+                &
144                           wee(ij+u_ldown,2,2)*ue(ij+t_ldown+u_left,l)+               &
145                           wee(ij+u_ldown,3,2)*ue(ij+t_ldown+u_ldown,l)+              &
146                           wee(ij+u_ldown,4,2)*ue(ij+t_ldown+u_rdown,l)+              &
147                           wee(ij+u_ldown,5,2)*ue(ij+t_ldown+u_right,l) ) 
148       
149        ENDDO
150      ENDDO
151    ENDDO
152                       
153 END SUBROUTINE compute_tangential_compound
154 
155 SUBROUTINE compute_wind_lonlat_compound(u, ulon, ulat)
156  USE icosa 
157   
158  IMPLICIT NONE
159  REAL(rstd) :: u(3*iim*jjm,3,llm)
160  REAL(rstd) :: ulon(3*iim*jjm,3,llm)
161  REAL(rstd) :: ulat(3*iim*jjm,3,llm)
162
163  INTEGER :: i,j,ij,l     
164   
165 
166    DO l=1,llm
167      DO j=jj_begin-1,jj_end+1
168        DO i=ii_begin-1,ii_end+1
169          ij=(j-1)*iim+i
170          ulon(ij+u_right,:,l)=sum(u(ij+u_right,:,l)*elon_e(ij+u_right,:))*elon_e(ij+u_right,:) 
171          ulon(ij+u_lup,:,l)=sum(u(ij+u_lup,:,l)*elon_e(ij+u_lup,:))*elon_e(ij+u_lup,:)
172          ulon(ij+u_ldown,:,l)=sum(u(ij+u_ldown,:,l)*elon_e(ij+u_ldown,:))*elon_e(ij+u_ldown,:)
173         
174          ulat(ij+u_right,:,l)=sum(u(ij+u_right,:,l)*elat_e(ij+u_right,:))*elat_e(ij+u_right,:) 
175          ulat(ij+u_lup,:,l)=sum(u(ij+u_lup,:,l)*elat_e(ij+u_lup,:))*elat_e(ij+u_lup,:) 
176          ulat(ij+u_ldown,:,l)=sum(u(ij+u_ldown,:,l)*elat_e(ij+u_ldown,:))*elat_e(ij+u_ldown,:) 
177         
178        ENDDO
179      ENDDO
180    ENDDO
181 
182 END SUBROUTINE compute_wind_lonlat_compound
183 
184  SUBROUTINE compute_wind_from_lonlat_compound(ulon, ulat, u)
185  USE icosa 
186   
187  IMPLICIT NONE
188  REAL(rstd) :: u(3*iim*jjm,3,llm)
189  REAL(rstd) :: ulon(3*iim*jjm,llm)
190  REAL(rstd) :: ulat(3*iim*jjm,llm)
191
192  INTEGER :: i,j,ij,l     
193 
194    DO l=1,llm
195      DO j=jj_begin-1,jj_end+1
196        DO i=ii_begin-1,ii_end+1
197          ij=(j-1)*iim+i
198          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,:)
199          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,:)
200          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,:)
201        ENDDO
202      ENDDO
203    ENDDO
204 
205  END SUBROUTINE compute_wind_from_lonlat_compound
206 
207  SUBROUTINE compute_wind_centered_from_lonlat_compound(ulon, ulat, u)
208  USE icosa 
209   
210  IMPLICIT NONE
211  REAL(rstd) :: u(iim*jjm,3,llm)
212  REAL(rstd) :: ulon(iim*jjm,llm)
213  REAL(rstd) :: ulat(iim*jjm,llm)
214
215  INTEGER :: i,j,ij,l     
216  DO l=1,llm
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,:,l)=ulon(ij,l)*elon_i(ij,:)+ ulat(ij,l)*elat_i(ij,:)
221        ENDDO
222      ENDDO
223    ENDDO
224 
225  END SUBROUTINE compute_wind_centered_from_lonlat_compound
226 
227  SUBROUTINE compute_wind2D_from_lonlat_compound(ulon, ulat, u)
228  USE icosa 
229 
230  IMPLICIT NONE
231  REAL(rstd) :: u(3*iim*jjm,3)
232  REAL(rstd) :: ulon(3*iim*jjm)
233  REAL(rstd) :: ulat(3*iim*jjm)
234 
235  INTEGER :: i,j,ij
236 
237  DO j=jj_begin-1,jj_end+1
238     DO i=ii_begin-1,ii_end+1
239        ij=(j-1)*iim+i
240        u(ij+u_right,:)=ulon(ij+u_right)*elon_e(ij+u_right,:)+ ulat(ij+u_right)*elat_e(ij+u_right,:)
241        u(ij+u_lup,:)=ulon(ij+u_lup)*elon_e(ij+u_lup,:) + ulat(ij+u_lup)*elat_e(ij+u_lup,:)
242        u(ij+u_ldown,:)=ulon(ij+u_ldown)*elon_e(ij+u_ldown,:) + ulat(ij+u_ldown)*elat_e(ij+u_ldown,:)
243     ENDDO
244  ENDDO
245   
246  END SUBROUTINE compute_wind2D_from_lonlat_compound
247 
248  SUBROUTINE compute_wind_perp_from_lonlat_compound(ulon, ulat, up)
249  USE icosa 
250   
251  IMPLICIT NONE
252  REAL(rstd) :: up(3*iim*jjm,llm)
253  REAL(rstd) :: ulon(3*iim*jjm,llm)
254  REAL(rstd) :: ulat(3*iim*jjm,llm)
255  REAL(rstd) :: u(3*iim*jjm,3,llm)
256
257  INTEGER :: i,j,ij,l     
258 
259   CALL compute_wind_from_lonlat_compound(ulon, ulat, u)
260
261    DO l=1,llm
262      DO j=jj_begin-1,jj_end+1
263        DO i=ii_begin-1,ii_end+1
264          ij=(j-1)*iim+i
265          up(ij+u_right,l)=sum(u(ij+u_right,:,l)*ep_e(ij+u_right,:))
266          up(ij+u_lup,l)=sum(u(ij+u_lup,:,l)*ep_e(ij+u_lup,:))
267          up(ij+u_ldown,l)=sum(u(ij+u_ldown,:,l)*ep_e(ij+u_ldown,:))
268        ENDDO
269      ENDDO
270    ENDDO
271 
272  END SUBROUTINE compute_wind_perp_from_lonlat_compound
273   
274  SUBROUTINE compute_wind2D_perp_from_lonlat_compound(ulon, ulat, up)
275  USE icosa 
276   
277  IMPLICIT NONE
278  REAL(rstd) :: up(3*iim*jjm)
279  REAL(rstd) :: ulon(3*iim*jjm)
280  REAL(rstd) :: ulat(3*iim*jjm)
281  REAL(rstd) :: u(3*iim*jjm,3)
282
283  INTEGER :: i,j,ij 
284 
285  CALL compute_wind2D_from_lonlat_compound(ulon, ulat, u)
286  DO j=jj_begin-1,jj_end+1
287     DO i=ii_begin-1,ii_end+1
288        ij=(j-1)*iim+i
289        up(ij+u_right)=sum(u(ij+u_right,:)*ep_e(ij+u_right,:))
290        up(ij+u_lup)=sum(u(ij+u_lup,:)*ep_e(ij+u_lup,:))
291        up(ij+u_ldown)=sum(u(ij+u_ldown,:)*ep_e(ij+u_ldown,:))
292     ENDDO
293  ENDDO
294   
295  END SUBROUTINE compute_wind2D_perp_from_lonlat_compound
296   
297 SUBROUTINE compute_wind_centered_lonlat_compound(uc, ulon, ulat)
298  USE icosa 
299   
300  IMPLICIT NONE
301  REAL(rstd) :: uc(iim*jjm,3,llm)
302  REAL(rstd) :: ulon(iim*jjm,llm)
303  REAL(rstd) :: ulat(iim*jjm,llm)
304
305  INTEGER :: i,j,ij,l     
306   
307 
308    DO l=1,llm
309      DO j=jj_begin,jj_end
310        DO i=ii_begin,ii_end
311          ij=(j-1)*iim+i
312          ulon(ij,l)=sum(uc(ij,:,l)*elon_i(ij,:))
313          ulat(ij,l)=sum(uc(ij,:,l)*elat_i(ij,:)) 
314        ENDDO
315      ENDDO
316    ENDDO
317 
318 END SUBROUTINE compute_wind_centered_lonlat_compound
319
320 SUBROUTINE compute_wind_centered_from_wind_lonlat_centered(ulon, ulat,uc)
321  USE icosa 
322   
323  IMPLICIT NONE
324  REAL(rstd) :: ulon(iim*jjm,llm)
325  REAL(rstd) :: ulat(iim*jjm,llm)
326  REAL(rstd) :: uc(iim*jjm,3,llm)
327
328  INTEGER :: i,j,ij,l     
329   
330 
331    DO l=1,llm
332      DO j=jj_begin,jj_end
333        DO i=ii_begin,ii_end
334          ij=(j-1)*iim+i
335          uc(ij,:,l)=ulon(ij,l)*elon_i(ij,:)+ulat(ij,l)*elat_i(ij,:)
336        ENDDO
337      ENDDO
338    ENDDO
339 
340 END SUBROUTINE compute_wind_centered_from_wind_lonlat_centered
341
342
343
344 SUBROUTINE compute_wind_perp_from_wind_centered(uc,un)
345  USE icosa 
346   
347  IMPLICIT NONE
348  REAL(rstd),INTENT(IN)   :: uc(iim*jjm,3,llm)
349  REAL(rstd),INTENT(OUT)  :: un(3*iim*jjm,llm)
350
351  INTEGER :: i,j,ij,l     
352   
353 
354    DO l=1,llm
355      DO j=jj_begin,jj_end
356        DO i=ii_begin,ii_end
357          ij=(j-1)*iim+i
358          un(ij+u_right,l) = sum(0.5*(uc(ij,:,l) + uc(ij+t_right,:,l))*ep_e(ij+u_right,:))
359          un(ij+u_lup,l) = sum(0.5*(uc(ij,:,l) + uc(ij+t_lup,:,l))*ep_e(ij+u_lup,:))
360          un(ij+u_ldown,l) = sum(0.5*(uc(ij,:,l) + uc(ij+t_ldown,:,l))*ep_e(ij+u_ldown,:))
361         ENDDO
362      ENDDO
363    ENDDO
364 
365 END SUBROUTINE compute_wind_perp_from_wind_centered
366
367
368 SUBROUTINE compute_un2ulonlat(un, ulon, ulat)
369  USE icosa 
370   
371  IMPLICIT NONE
372  REAL(rstd),INTENT(IN)  :: un(3*iim*jjm,llm)
373  REAL(rstd),INTENT(OUT) :: ulon(iim*jjm,llm)
374  REAL(rstd),INTENT(OUT) :: ulat(iim*jjm,llm)
375
376  REAL(rstd)             :: uc(iim*jjm,3,llm)
377   
378  CALL compute_wind_centered(un,uc) 
379  CALL compute_wind_centered_lonlat_compound(uc, ulon, ulat)
380 
381 END SUBROUTINE compute_un2ulonlat
382
383 SUBROUTINE compute_ulonlat2un(ulon, ulat,un)
384  USE icosa 
385   
386  IMPLICIT NONE
387  REAL(rstd),INTENT(IN) :: ulon(iim*jjm,llm)
388  REAL(rstd),INTENT(IN) :: ulat(iim*jjm,llm)
389  REAL(rstd),INTENT(OUT)  :: un(3*iim*jjm,llm)
390
391  REAL(rstd)             :: uc(iim*jjm,3,llm)
392   
393    CALL compute_wind_centered_from_wind_lonlat_centered(ulon, ulat, uc) 
394    CALL compute_wind_perp_from_wind_centered(uc, un)
395 
396 END SUBROUTINE compute_ulonlat2un
397
398
399END MODULE wind_mod
Note: See TracBrowser for help on using the repository browser.