source: codes/icosagcm/trunk/src/diagnostics/wind.f90 @ 581

Last change on this file since 581 was 548, checked in by dubos, 7 years ago

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