source: LMDZ5/trunk/libf/addfi_loc.F @ 1630

Last change on this file since 1630 was 1630, checked in by Laurent Fairhead, 12 years ago

Importation initiale du répertoire dyn3dmem


Initial import of dyn3dmem directory

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