source: trunk/LMDZ.COMMON/libf/dyn3dpar/addfi_p.F @ 1685

Last change on this file since 1685 was 1422, checked in by milmd, 10 years ago

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