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