source: LMDZ5/trunk/libf/dyn3dpar/addfi_p.F @ 1966

Last change on this file since 1966 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.0 KB
Line 
1!
2! $Id: addfi_p.F 1907 2013-11-26 13:10:46Z fairhead $
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
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 pdt
58c
59      REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
60      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1)
61c
62      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
63      REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
64c
65      LOGICAL leapf,forward
66c
67c
68c    Local variables :
69c    -----------------
70c
71      REAL xpn(iim),xps(iim),tpn,tps
72      INTEGER j,k,iq,ij
73      REAL qtestw, qtestt
74      PARAMETER ( qtestw = 1.0e-15 )
75      PARAMETER ( qtestt = 1.0e-40 )
76
77      REAL SSUM
78      EXTERNAL SSUM
79     
80      INTEGER :: ijb,ije
81c
82c-----------------------------------------------------------------------
83     
84      ijb=ij_begin
85      ije=ij_end
86     
87c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
88      DO k = 1,llm
89         DO j = ijb,ije
90            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
91         ENDDO
92      ENDDO
93c$OMP END DO NOWAIT
94
95      if (pole_nord) then
96c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
97        DO  k    = 1, llm
98         DO  ij   = 1, iim
99           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
100         ENDDO
101         tpn      = SSUM(iim,xpn,1)/ apoln
102
103         DO ij   = 1, iip1
104           pteta(   ij   ,k)  = tpn
105         ENDDO
106       ENDDO
107c$OMP END DO NOWAIT
108      endif
109
110      if (pole_sud) then
111c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
112        DO  k    = 1, llm
113         DO  ij   = 1, iim
114           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
115         ENDDO
116         tps      = SSUM(iim,xps,1)/ apols
117
118         DO ij   = 1, iip1
119           pteta(ij+ip1jm,k)  = tps
120         ENDDO
121       ENDDO
122c$OMP END DO NOWAIT
123      endif
124c
125
126      ijb=ij_begin
127      ije=ij_end
128      if (pole_nord) ijb=ij_begin+iip1
129      if (pole_sud)  ije=ij_end-iip1
130
131c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
132      DO k = 1,llm
133         DO j = ijb,ije
134            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
135         ENDDO
136      ENDDO
137c$OMP END DO NOWAIT
138
139      if (pole_nord) ijb=ij_begin
140
141c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
142      DO k = 1,llm
143         DO j = ijb,ije
144            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
145         ENDDO
146      ENDDO
147c$OMP END DO NOWAIT
148
149c
150      if (pole_sud)  ije=ij_end
151c$OMP MASTER
152      DO j = ijb,ije
153         pps(j) = pps(j) + pdpfi(j) * pdt
154      ENDDO
155c$OMP END MASTER
156 
157      if (planet_type=="earth") then
158      ! earth case, special treatment for first 2 tracers (water)
159       DO iq = 1, 2
160c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
161         DO k = 1,llm
162            DO j = ijb,ije
163               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
164               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
165            ENDDO
166         ENDDO
167c$OMP END DO NOWAIT
168       ENDDO
169
170       DO iq = 3, nqtot
171c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
172         DO k = 1,llm
173            DO j = ijb,ije
174               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
175               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
176            ENDDO
177         ENDDO
178c$OMP END DO NOWAIT
179       ENDDO
180      else
181      ! general case, treat all tracers equally)
182       DO iq = 1, nqtot
183c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
184         DO k = 1,llm
185            DO j = ijb,ije
186               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
187               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
188            ENDDO
189         ENDDO
190c$OMP END DO NOWAIT
191       ENDDO
192      endif ! of if (planet_type=="earth")
193
194c$OMP MASTER
195      if (pole_nord) then
196     
197        DO  ij   = 1, iim
198          xpn(ij) = aire(   ij   ) * pps(  ij     )
199        ENDDO
200
201        tpn      = SSUM(iim,xpn,1)/apoln
202
203        DO ij   = 1, iip1
204          pps (   ij     )  = tpn
205        ENDDO
206     
207      endif
208
209      if (pole_sud) then
210     
211        DO  ij   = 1, iim
212          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
213        ENDDO
214
215        tps      = SSUM(iim,xps,1)/apols
216
217        DO ij   = 1, iip1
218          pps ( ij+ip1jm )  = tps
219        ENDDO
220     
221      endif
222c$OMP END MASTER
223
224      if (pole_nord) then
225        DO iq = 1, nqtot
226c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
227          DO  k    = 1, llm
228            DO  ij   = 1, iim
229              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
230            ENDDO
231            tpn      = SSUM(iim,xpn,1)/apoln
232 
233            DO ij   = 1, iip1
234              pq (   ij   ,k,iq)  = tpn
235            ENDDO
236          ENDDO
237c$OMP END DO NOWAIT       
238        ENDDO
239      endif
240     
241      if (pole_sud) then
242        DO iq = 1, nqtot
243c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
244          DO  k    = 1, llm
245            DO  ij   = 1, iim
246              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
247            ENDDO
248            tps      = SSUM(iim,xps,1)/apols
249 
250            DO ij   = 1, iip1
251              pq (ij+ip1jm,k,iq)  = tps
252            ENDDO
253          ENDDO
254c$OMP END DO NOWAIT       
255        ENDDO
256      endif
257     
258     
259      RETURN
260      END
Note: See TracBrowser for help on using the repository browser.