source: LMDZ5/trunk/libf/dyn3dmem/addfi_loc.F @ 1915

Last change on this file since 1915 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
File size: 6.1 KB
Line 
1!
2! $Id$
3!
4      SUBROUTINE addfi_loc(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(ijb_v:ije_v,llm),pucov(ijb_u:ije_u,llm)
60      REAL pteta(ijb_u:ije_u,llm),pq(ijb_u:ije_u,llm,nqtot)
61      REAL pps(ijb_u:ije_u)
62c
63      REAL pdvfi(ijb_v:ije_v,llm),pdufi(ijb_u:ije_u,llm)
64      REAL pdqfi(ijb_u:ije_u,llm,nqtot),pdhfi(ijb_u:ije_u,llm)
65      REAL pdpfi(ijb_u:ije_u)
66c
67      LOGICAL leapf,forward
68c
69c
70c    Local variables :
71c    -----------------
72c
73      REAL xpn(iim),xps(iim),tpn,tps
74      INTEGER j,k,iq,ij
75      REAL qtestw, qtestt
76      PARAMETER ( qtestw = 1.0e-15 )
77      PARAMETER ( qtestt = 1.0e-40 )
78
79      REAL SSUM
80      EXTERNAL SSUM
81     
82      INTEGER :: ijb,ije
83c
84c-----------------------------------------------------------------------
85     
86      ijb=ij_begin
87      ije=ij_end
88     
89c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
90      DO k = 1,llm
91         DO j = ijb,ije
92            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
93         ENDDO
94      ENDDO
95c$OMP END DO NOWAIT
96
97      if (pole_nord) then
98c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
99        DO  k    = 1, llm
100         DO  ij   = 1, iim
101           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
102         ENDDO
103         tpn      = SSUM(iim,xpn,1)/ apoln
104
105         DO ij   = 1, iip1
106           pteta(   ij   ,k)  = tpn
107         ENDDO
108       ENDDO
109c$OMP END DO NOWAIT
110      endif
111
112      if (pole_sud) then
113c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
114        DO  k    = 1, llm
115         DO  ij   = 1, iim
116           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
117         ENDDO
118         tps      = SSUM(iim,xps,1)/ apols
119
120         DO ij   = 1, iip1
121           pteta(ij+ip1jm,k)  = tps
122         ENDDO
123       ENDDO
124c$OMP END DO NOWAIT
125      endif
126c
127
128      ijb=ij_begin
129      ije=ij_end
130      if (pole_nord) ijb=ij_begin+iip1
131      if (pole_sud)  ije=ij_end-iip1
132
133c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
134      DO k = 1,llm
135         DO j = ijb,ije
136            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
137         ENDDO
138      ENDDO
139c$OMP END DO NOWAIT
140
141      if (pole_nord) ijb=ij_begin
142
143c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
144      DO k = 1,llm
145         DO j = ijb,ije
146            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
147         ENDDO
148      ENDDO
149c$OMP END DO NOWAIT
150
151c
152      if (pole_sud)  ije=ij_end
153c$OMP MASTER
154      DO j = ijb,ije
155         pps(j) = pps(j) + pdpfi(j) * pdt
156      ENDDO
157c$OMP END MASTER
158 
159      if (planet_type=="earth") then
160      ! earth case, special treatment for first 2 tracers (water)
161      DO iq = 1, 2
162c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
163         DO k = 1,llm
164            DO j = ijb,ije
165               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
166               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
167            ENDDO
168         ENDDO
169c$OMP END DO NOWAIT
170      ENDDO
171
172      DO iq = 3, nqtot
173c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
174         DO k = 1,llm
175            DO j = ijb,ije
176               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
177               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
178            ENDDO
179         ENDDO
180c$OMP END DO NOWAIT
181      ENDDO
182      else
183      ! general case, treat all tracers equally)
184       DO iq = 1, nqtot
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
192c$OMP END DO NOWAIT
193       ENDDO
194      endif ! of if (planet_type=="earth")
195
196c$OMP MASTER
197      if (pole_nord) then
198     
199        DO  ij   = 1, iim
200          xpn(ij) = aire(   ij   ) * pps(  ij     )
201        ENDDO
202
203        tpn      = SSUM(iim,xpn,1)/apoln
204
205        DO ij   = 1, iip1
206          pps (   ij     )  = tpn
207        ENDDO
208     
209      endif
210
211      if (pole_sud) then
212     
213        DO  ij   = 1, iim
214          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
215        ENDDO
216
217        tps      = SSUM(iim,xps,1)/apols
218
219        DO ij   = 1, iip1
220          pps ( ij+ip1jm )  = tps
221        ENDDO
222     
223      endif
224c$OMP END MASTER
225
226      if (pole_nord) then
227        DO iq = 1, nqtot
228c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
229          DO  k    = 1, llm
230            DO  ij   = 1, iim
231              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
232            ENDDO
233            tpn      = SSUM(iim,xpn,1)/apoln
234 
235            DO ij   = 1, iip1
236              pq (   ij   ,k,iq)  = tpn
237            ENDDO
238          ENDDO
239c$OMP END DO NOWAIT       
240        ENDDO
241      endif
242     
243      if (pole_sud) then
244        DO iq = 1, nqtot
245c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
246          DO  k    = 1, llm
247            DO  ij   = 1, iim
248              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
249            ENDDO
250            tps      = SSUM(iim,xps,1)/apols
251 
252            DO ij   = 1, iip1
253              pq (ij+ip1jm,k,iq)  = tps
254            ENDDO
255          ENDDO
256c$OMP END DO NOWAIT       
257        ENDDO
258      endif
259     
260     
261      RETURN
262      END
Note: See TracBrowser for help on using the repository browser.