source: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/addfi_p.F @ 222

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

Creating temporary dynamico/lmdz/saturn branche

YM
File size: 6.8 KB
Line 
1!
2! $Id: addfi_p.F 1446 2010-10-22 09:27:25Z emillour $
3!
4      SUBROUTINE addfi_p(pdt, leapf, forward,
5     S          pucov, pvcov, pteta, pq   , pps ,
6     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
7      USE parallel_lmdz
8      USE infotrac, ONLY : nqtot
9      USE control_mod, ONLY : planet_type
10      IMPLICIT NONE
11c
12c=======================================================================
13c
14c    Addition of the physical tendencies
15c
16c    Interface :
17c    -----------
18c
19c      Input :
20c      -------
21c      pdt                    time step of integration
22c      leapf                  logical
23c      forward                logical
24c      pucov(ip1jmp1,llm)     first component of the covariant velocity
25c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
26c      pteta(ip1jmp1,llm)     potential temperature
27c      pts(ip1jmp1,llm)       surface temperature
28c      pdufi(ip1jmp1,llm)     |
29c      pdvfi(ip1jm,llm)       |   respective
30c      pdhfi(ip1jmp1)         |      tendencies  (unit/s)
31c      pdtsfi(ip1jmp1)        |
32c
33c      Output :
34c      --------
35c      pucov
36c      pvcov
37c      ph
38c      pts
39c
40c
41c=======================================================================
42c
43c-----------------------------------------------------------------------
44c
45c    0.  Declarations :
46c    ------------------
47c
48#include "dimensions.h"
49#include "paramet.h"
50#include "comconst.h"
51#include "comgeom.h"
52#include "serre.h"
53c
54c    Arguments :
55c    -----------
56c
57      REAL,INTENT(IN) :: pdt ! time step for the integration (s)
58c
59      REAL,INTENT(INOUT) :: pvcov(ip1jm,llm) ! covariant meridional wind
60      REAL,INTENT(INOUT) :: pucov(ip1jmp1,llm) ! covariant zonal wind
61      REAL,INTENT(INOUT) :: pteta(ip1jmp1,llm) ! potential temperature
62      REAL,INTENT(INOUT) :: pq(ip1jmp1,llm,nqtot) ! tracers
63      REAL,INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
64c respective tendencies (.../s) to add
65      REAL,INTENT(IN) :: pdvfi(ip1jm,llm)
66      REAL,INTENT(IN) :: pdufi(ip1jmp1,llm)
67      REAL,INTENT(IN) :: pdqfi(ip1jmp1,llm,nqtot)
68      REAL,INTENT(IN) :: pdhfi(ip1jmp1,llm)
69      REAL,INTENT(IN) :: pdpfi(ip1jmp1)
70c
71      LOGICAL,INTENT(IN) :: leapf,forward ! not used
72c
73c
74c    Local variables :
75c    -----------------
76c
77      REAL xpn(iim),xps(iim),tpn,tps
78      INTEGER j,k,iq,ij
79      REAL,PARAMETER :: qtestw = 1.0e-15
80      REAL,PARAMETER :: qtestt = 1.0e-40
81
82      REAL SSUM
83      EXTERNAL SSUM
84     
85      INTEGER :: ijb,ije
86c
87c-----------------------------------------------------------------------
88     
89      ijb=ij_begin
90      ije=ij_end
91     
92c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
93      DO k = 1,llm
94         DO j = ijb,ije
95            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
96         ENDDO
97      ENDDO
98c$OMP END DO NOWAIT
99
100      if (pole_nord) then
101c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
102        DO  k    = 1, llm
103         DO  ij   = 1, iim
104           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
105         ENDDO
106         tpn      = SSUM(iim,xpn,1)/ apoln
107
108         DO ij   = 1, iip1
109           pteta(   ij   ,k)  = tpn
110         ENDDO
111       ENDDO
112c$OMP END DO NOWAIT
113      endif
114
115      if (pole_sud) then
116c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
117        DO  k    = 1, llm
118         DO  ij   = 1, iim
119           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
120         ENDDO
121         tps      = SSUM(iim,xps,1)/ apols
122
123         DO ij   = 1, iip1
124           pteta(ij+ip1jm,k)  = tps
125         ENDDO
126       ENDDO
127c$OMP END DO NOWAIT
128      endif
129c
130!***********************
131! Correction on teta due to surface pressure changes
132c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
133      DO k = 1,llm
134        DO j = ijb,ije
135           pteta(j,k)= pteta(j,k)*(1+pdpfi(j)*pdt/pps(j))**kappa
136        ENDDO
137      ENDDO
138c$OMP END DO NOWAIT
139!***********************
140
141      ijb=ij_begin
142      ije=ij_end
143      if (pole_nord) ijb=ij_begin+iip1
144      if (pole_sud)  ije=ij_end-iip1
145
146c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
147      DO k = 1,llm
148         DO j = ijb,ije
149            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
150         ENDDO
151      ENDDO
152c$OMP END DO NOWAIT
153
154      if (pole_nord) ijb=ij_begin
155
156c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
157      DO k = 1,llm
158         DO j = ijb,ije
159            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
160         ENDDO
161      ENDDO
162c$OMP END DO NOWAIT
163
164c
165      if (pole_sud)  ije=ij_end
166c$OMP MASTER
167      DO j = ijb,ije
168         pps(j) = pps(j) + pdpfi(j) * pdt
169      ENDDO
170c$OMP END MASTER
171 
172      if (planet_type=="earth") then
173      ! earth case, special treatment for first 2 tracers (water)
174       DO iq = 1, 2
175c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
176         DO k = 1,llm
177            DO j = ijb,ije
178               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
179               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
180            ENDDO
181         ENDDO
182c$OMP END DO NOWAIT
183       ENDDO
184
185       DO iq = 3, nqtot
186c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
187         DO k = 1,llm
188            DO j = ijb,ije
189               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
190               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
191            ENDDO
192         ENDDO
193c$OMP END DO NOWAIT
194       ENDDO
195      else
196      ! general case, treat all tracers equally)
197       DO iq = 1, nqtot
198c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
199         DO k = 1,llm
200            DO j = ijb,ije
201               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
202               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
203            ENDDO
204         ENDDO
205c$OMP END DO NOWAIT
206       ENDDO
207      endif ! of if (planet_type=="earth")
208
209c$OMP MASTER
210      if (pole_nord) then
211     
212        DO  ij   = 1, iim
213          xpn(ij) = aire(   ij   ) * pps(  ij     )
214        ENDDO
215
216        tpn      = SSUM(iim,xpn,1)/apoln
217
218        DO ij   = 1, iip1
219          pps (   ij     )  = tpn
220        ENDDO
221     
222      endif
223
224      if (pole_sud) then
225     
226        DO  ij   = 1, iim
227          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
228        ENDDO
229
230        tps      = SSUM(iim,xps,1)/apols
231
232        DO ij   = 1, iip1
233          pps ( ij+ip1jm )  = tps
234        ENDDO
235     
236      endif
237c$OMP END MASTER
238
239      if (pole_nord) then
240        DO iq = 1, nqtot
241c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
242          DO  k    = 1, llm
243            DO  ij   = 1, iim
244              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
245            ENDDO
246            tpn      = SSUM(iim,xpn,1)/apoln
247 
248            DO ij   = 1, iip1
249              pq (   ij   ,k,iq)  = tpn
250            ENDDO
251          ENDDO
252c$OMP END DO NOWAIT       
253        ENDDO
254      endif
255     
256      if (pole_sud) then
257        DO iq = 1, nqtot
258c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
259          DO  k    = 1, llm
260            DO  ij   = 1, iim
261              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
262            ENDDO
263            tps      = SSUM(iim,xps,1)/apols
264 
265            DO ij   = 1, iip1
266              pq (ij+ip1jm,k,iq)  = tps
267            ENDDO
268          ENDDO
269c$OMP END DO NOWAIT       
270        ENDDO
271      endif
272     
273     
274      RETURN
275      END
Note: See TracBrowser for help on using the repository browser.