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

Last change on this file since 252 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
RevLine 
[15]1MODULE wind_mod
2
[49]3CONTAINS
[15]4
[151]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
[15]13
[151]14    DO ind=1,ndomain
[186]15       IF (.NOT. assigned_domain(ind)) CYCLE
[151]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
[15]26 
27  SUBROUTINE compute_wind_centered(ue,ucenter)
[19]28  USE icosa
[15]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
[21]39          ucenter(ij,:,l)=1/Ai(ij)*                                                                                                &
[49]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,:)))
[15]46        ENDDO
47      ENDDO
48    ENDDO
49 
50 END SUBROUTINE compute_wind_centered
51 
52 
53 SUBROUTINE compute_wind_on_edge(ue,uedge)
[19]54  USE icosa
[15]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)
[19]81  USE icosa 
[15]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)
[19]136  USE icosa 
[15]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)
[19]165  USE icosa 
[15]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 
[196]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 
[179]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 
[36]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
[15]251 
[36]252  END SUBROUTINE compute_wind_perp_from_lonlat_compound
253   
[179]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   
[15]277 SUBROUTINE compute_wind_centered_lonlat_compound(uc, ulon, ulat)
[19]278  USE icosa 
[15]279   
280  IMPLICIT NONE
[36]281  REAL(rstd) :: uc(iim*jjm,3,llm)
[38]282  REAL(rstd) :: ulon(iim*jjm,llm)
283  REAL(rstd) :: ulat(iim*jjm,llm)
[15]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
[36]292          ulon(ij,l)=sum(uc(ij,:,l)*elon_i(ij,:))
293          ulat(ij,l)=sum(uc(ij,:,l)*elat_i(ij,:)) 
[15]294        ENDDO
295      ENDDO
296    ENDDO
297 
298 END SUBROUTINE compute_wind_centered_lonlat_compound
299
[151]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)
[15]307
[151]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
[15]315END MODULE wind_mod
Note: See TracBrowser for help on using the repository browser.