source: LMDZ4/branches/V3_test/libf/dyn3dpar/addfi_p.F @ 2520

Last change on this file since 2520 was 709, checked in by Laurent Fairhead, 18 years ago

Nouvelles versions de la dynamique YM
LF

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