source: codes/icosagcm/trunk/src/theta_rhodz.f90 @ 387

Last change on this file since 387 was 387, checked in by dubos, 8 years ago

Infrastructure for multiple dynamical tracers - tested with JW06 and moist baroclinic wave
File size: 6.9 KB
Line 
1MODULE theta2theta_rhodz_mod
2  USE field_mod
3 
4  TYPE(t_field), POINTER, SAVE  :: f_p(:)
5  TYPE(t_field), POINTER, SAVE  :: f_pks(:)
6  TYPE(t_field), POINTER, SAVE  :: f_pk(:)
7
8  PRIVATE :: f_p,f_pk,f_pks 
9
10CONTAINS
11 
12  SUBROUTINE init_theta2theta_rhodz
13  USE icosa
14  USE field_mod
15  IMPLICIT NONE
16    CALL allocate_field(f_p,field_t,type_real,llm+1,name='p (theta2theta_rhodz_mod)')
17    CALL allocate_field(f_pk,field_t,type_real,llm,name='pk (theta2theta_rhodz_mod)')
18    CALL allocate_field(f_pks,field_t,type_real,name='pks (theta2theta_rhodz_mod)')
19   
20  END SUBROUTINE init_theta2theta_rhodz
21
22
23
24  SUBROUTINE theta_rhodz2theta(f_ps,f_theta_rhodz,f_theta)
25  USE icosa
26  IMPLICIT NONE
27    TYPE(t_field), POINTER :: f_ps(:)
28    TYPE(t_field), POINTER :: f_theta_rhodz(:)
29    TYPE(t_field), POINTER :: f_theta(:)
30 
31    REAL(rstd), POINTER :: ps(:)
32    REAL(rstd), POINTER :: theta_rhodz(:,:)
33    REAL(rstd), POINTER :: theta(:,:)
34    INTEGER :: ind
35
36!$OMP BARRIER
37    DO ind=1,ndomain
38      IF (.NOT. assigned_domain(ind)) CYCLE
39      CALL swap_dimensions(ind)
40      CALL swap_geometry(ind)
41      ps=f_ps(ind)
42      theta_rhodz=f_theta_rhodz(ind)
43      theta=f_theta(ind)
44      CALL compute_theta_rhodz2theta(ps, theta_rhodz,theta,0)
45    ENDDO
46!$OMP BARRIER
47 
48  END SUBROUTINE theta_rhodz2theta
49
50  SUBROUTINE theta_rhodz2temperature(f_ps,f_theta_rhodz,f_temp)
51  USE icosa
52  USE pression_mod
53  USE exner_mod
54  IMPLICIT NONE
55    TYPE(t_field), POINTER :: f_ps(:)
56    TYPE(t_field), POINTER :: f_theta_rhodz(:)
57    TYPE(t_field), POINTER :: f_temp(:)
58 
59    REAL(rstd), POINTER :: ps(:)
60    REAL(rstd), POINTER :: theta_rhodz(:,:,:)
61    REAL(rstd), POINTER :: temp(:,:)
62    REAL(rstd), POINTER :: p(:,:)
63    REAL(rstd), POINTER :: pk(:,:)
64    REAL(rstd), POINTER :: pks(:)
65    INTEGER :: ind
66
67    DO ind=1,ndomain
68      IF (.NOT. assigned_domain(ind)) CYCLE
69      CALL swap_dimensions(ind)
70      CALL swap_geometry(ind)
71      ps=f_ps(ind)
72      p=f_p(ind)
73      pks=f_pks(ind)
74      pk=f_pk(ind)
75      theta_rhodz=f_theta_rhodz(ind)
76      temp=f_temp(ind)
77
78!$OMP BARRIER
79      CALL compute_pression(ps,p,0)
80!$OMP BARRIER
81      CALL compute_exner(ps,p,pks,pk,0)
82!$OMP BARRIER
83      CALL compute_theta_rhodz2temperature(p, pk, theta_rhodz(:,:,1),temp,0)
84    ENDDO
85!$OMP BARRIER
86 
87  END SUBROUTINE theta_rhodz2temperature
88 
89  SUBROUTINE temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz)
90  USE icosa
91  USE pression_mod
92  USE exner_mod
93  IMPLICIT NONE
94    TYPE(t_field), POINTER :: f_ps(:)
95    TYPE(t_field), POINTER :: f_theta_rhodz(:)
96    TYPE(t_field), POINTER :: f_temp(:)
97 
98    REAL(rstd), POINTER :: ps(:)
99    REAL(rstd), POINTER :: theta_rhodz(:,:,:)
100    REAL(rstd), POINTER :: temp(:,:)
101    REAL(rstd), POINTER :: p(:,:)
102    REAL(rstd), POINTER :: pk(:,:)
103    REAL(rstd), POINTER :: pks(:)
104    INTEGER :: ind
105
106    DO ind=1,ndomain
107      IF (.NOT. assigned_domain(ind)) CYCLE
108      CALL swap_dimensions(ind)
109      CALL swap_geometry(ind)
110      ps=f_ps(ind)
111      p=f_p(ind)
112      pks=f_pks(ind)
113      pk=f_pk(ind)
114      theta_rhodz=f_theta_rhodz(ind)
115      temp=f_temp(ind)
116
117!$OMP BARRIER
118      CALL compute_pression(ps,p,0)
119!$OMP BARRIER
120      CALL compute_exner(ps,p,pks,pk,0)
121!$OMP BARRIER
122      CALL compute_temperature2theta_rhodz(p, pk, temp, theta_rhodz(:,:,1), 0)
123    ENDDO
124!$OMP BARRIER
125 
126  END SUBROUTINE temperature2theta_rhodz
127 
128 
129   
130  SUBROUTINE theta2theta_rhodz(f_ps,f_theta,f_theta_rhodz)
131  USE icosa
132  IMPLICIT NONE
133    TYPE(t_field), POINTER :: f_ps(:)
134    TYPE(t_field), POINTER :: f_theta(:)
135    TYPE(t_field), POINTER :: f_theta_rhodz(:)
136 
137    REAL(rstd), POINTER :: ps(:)
138    REAL(rstd), POINTER :: theta(:,:)
139    REAL(rstd), POINTER :: theta_rhodz(:,:)
140    INTEGER :: ind
141
142!$OMP BARRIER
143    DO ind=1,ndomain
144      IF (.NOT. assigned_domain(ind)) CYCLE
145      CALL swap_dimensions(ind)
146      CALL swap_geometry(ind)
147      ps=f_ps(ind)
148      theta=f_theta(ind)
149      theta_rhodz=f_theta_rhodz(ind)
150      CALL compute_theta2theta_rhodz(ps, theta, theta_rhodz,0)
151    ENDDO
152!$OMP BARRIER
153 
154  END SUBROUTINE theta2theta_rhodz
155 
156  SUBROUTINE compute_theta2theta_rhodz(ps,theta, theta_rhodz,offset)
157  USE icosa
158  USE disvert_mod
159  USE omp_para
160  IMPLICIT NONE
161    REAL(rstd),INTENT(IN) :: ps(iim*jjm)
162    REAL(rstd),INTENT(IN) :: theta(iim*jjm,llm)
163    REAL(rstd),INTENT(OUT) :: theta_rhodz(iim*jjm,llm)
164    INTEGER,INTENT(IN) :: offset
165    REAL(rstd) :: rhodz
166    INTEGER :: i,j,ij,l
167   
168!$OMP BARRIER
169    DO    l    = ll_begin, ll_end
170      DO j=jj_begin-offset,jj_end+offset
171        DO i=ii_begin-offset,ii_end+offset
172          ij=(j-1)*iim+i
173          rhodz = ( ap(l)-ap(l+1) + (bp(l)-bp(l+1))*ps(ij) )/g
174          theta_rhodz(ij,l) = theta(ij,l) * rhodz
175        ENDDO
176      ENDDO
177    ENDDO
178!$OMP BARRIER
179
180
181  END SUBROUTINE compute_theta2theta_rhodz
182
183  SUBROUTINE compute_theta_rhodz2theta(ps,theta_rhodz,theta,offset)
184  USE icosa
185  USE disvert_mod
186  USE omp_para
187  IMPLICIT NONE
188    REAL(rstd),INTENT(IN) :: ps(iim*jjm)
189    REAL(rstd),INTENT(IN) :: theta_rhodz(iim*jjm,llm)
190    REAL(rstd),INTENT(OUT) :: theta(iim*jjm,llm)
191    INTEGER,INTENT(IN) :: offset
192    REAL(rstd) :: rhodz
193    INTEGER :: i,j,ij,l
194
195!$OMP BARRIER
196    DO    l    = ll_begin, ll_end
197      DO j=jj_begin-offset,jj_end+offset
198        DO i=ii_begin-offset,ii_end+offset
199          ij=(j-1)*iim+i
200          rhodz = ( ap(l)-ap(l+1) + (bp(l)-bp(l+1))*ps(ij) )/g
201          theta(ij,l) = theta_rhodz(ij,l) / rhodz
202        ENDDO
203      ENDDO
204    ENDDO
205!$OMP BARRIER
206
207   
208  END SUBROUTINE compute_theta_rhodz2theta
209
210
211
212
213
214
215  SUBROUTINE compute_theta_rhodz2temperature(p,pk,theta_rhodz,temp,offset)
216  USE icosa
217  USE pression_mod
218  USE exner_mod
219  USE omp_para
220  IMPLICIT NONE
221    REAL(rstd),INTENT(IN) :: p(iim*jjm,llm+1)
222    REAL(rstd),INTENT(IN) :: pk(iim*jjm,llm)
223    REAL(rstd),INTENT(IN) :: theta_rhodz(iim*jjm,llm)
224    REAL(rstd),INTENT(OUT) :: temp(iim*jjm,llm)
225    INTEGER,INTENT(IN) :: offset
226    INTEGER :: i,j,ij,l
227       
228! flush p
229!$OMP BARRIER
230    DO    l    = ll_begin, ll_end
231      DO j=jj_begin-offset,jj_end+offset
232        DO i=ii_begin-offset,ii_end+offset
233          ij=(j-1)*iim+i
234          temp(ij,l) = ( theta_rhodz(ij,l) / ((p(ij,l)-p(ij,l+1))/g) ) * pk(ij,l) / cpp
235        ENDDO
236      ENDDO
237    ENDDO
238!$OMP BARRIER
239   
240   
241  END SUBROUTINE compute_theta_rhodz2temperature
242
243  SUBROUTINE compute_temperature2theta_rhodz(p,pk,temp,theta_rhodz,offset)
244  USE icosa
245  USE pression_mod
246  USE exner_mod
247  USE omp_para
248  IMPLICIT NONE
249    REAL(rstd),INTENT(IN)  :: p(iim*jjm,llm+1)
250    REAL(rstd),INTENT(IN)  :: pk(iim*jjm,llm)
251    REAL(rstd),INTENT(OUT) :: theta_rhodz(iim*jjm,llm)
252    REAL(rstd),INTENT(IN)  :: temp(iim*jjm,llm)
253    INTEGER,INTENT(IN) :: offset
254    INTEGER :: i,j,ij,l
255
256       
257! flush p
258!$OMP BARRIER
259
260    DO    l    = ll_begin, ll_end
261      DO j=jj_begin-offset,jj_end+offset
262        DO i=ii_begin-offset,ii_end+offset
263          ij=(j-1)*iim+i
264          theta_rhodz(ij,l) = temp(ij,l) * ((p(ij,l)-p(ij,l+1))/g) / (pk(ij,l) / cpp )
265        ENDDO
266      ENDDO
267    ENDDO
268!$OMP BARRIER
269   
270  END SUBROUTINE compute_temperature2theta_rhodz
271   
272END MODULE theta2theta_rhodz_mod
Note: See TracBrowser for help on using the repository browser.