source: LMDZ4/branches/pre_V3/libf/dyn3dpar/addfi_p.F @ 3400

Last change on this file since 3400 was 630, checked in by Laurent Fairhead, 20 years ago

Import d'une version parallele de la dynamique YM
LF
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.9 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     
84      DO k = 1,llm
85         DO j = ijb,ije
86            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
87         ENDDO
88      ENDDO
89
90      if (pole_nord) then
91        DO  k    = 1, llm
92         DO  ij   = 1, iim
93           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
94         ENDDO
95         tpn      = SSUM(iim,xpn,1)/ apoln
96
97         DO ij   = 1, iip1
98           pteta(   ij   ,k)  = tpn
99         ENDDO
100       ENDDO
101      endif
102
103      if (pole_sud) then
104        DO  k    = 1, llm
105         DO  ij   = 1, iim
106           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
107         ENDDO
108         tps      = SSUM(iim,xps,1)/ apols
109
110         DO ij   = 1, iip1
111           pteta(ij+ip1jm,k)  = tps
112         ENDDO
113       ENDDO
114      endif
115c
116
117      ijb=ij_begin
118      ije=ij_end
119      if (pole_nord) ijb=ij_begin+iip1
120      if (pole_sud)  ije=ij_end-iip1
121     
122      DO k = 1,llm
123         DO j = ijb,ije
124            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
125         ENDDO
126      ENDDO
127
128      if (pole_nord) ijb=ij_begin
129
130      DO k = 1,llm
131         DO j = ijb,ije
132            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
133         ENDDO
134      ENDDO
135
136c
137      if (pole_sud)  ije=ij_end
138
139      DO j = ijb,ije
140         pps(j) = pps(j) + pdpfi(j) * pdt
141      ENDDO
142 
143 
144      DO iq = 1, 2
145         DO k = 1,llm
146            DO j = ijb,ije
147               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
148               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
149            ENDDO
150         ENDDO
151      ENDDO
152
153
154      DO iq = 3, nq
155         DO k = 1,llm
156            DO j = ijb,ije
157               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
158               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
159            ENDDO
160         ENDDO
161      ENDDO
162
163      if (pole_nord) then
164     
165        DO  ij   = 1, iim
166          xpn(ij) = aire(   ij   ) * pps(  ij     )
167        ENDDO
168
169        tpn      = SSUM(iim,xpn,1)/apoln
170
171        DO ij   = 1, iip1
172          pps (   ij     )  = tpn
173        ENDDO
174     
175      endif
176
177      if (pole_sud) then
178     
179        DO  ij   = 1, iim
180          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
181        ENDDO
182
183        tps      = SSUM(iim,xps,1)/apols
184
185        DO ij   = 1, iip1
186          pps ( ij+ip1jm )  = tps
187        ENDDO
188     
189      endif
190
191      if (pole_nord) then
192        DO iq = 1, nq
193          DO  k    = 1, llm
194            DO  ij   = 1, iim
195              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
196            ENDDO
197            tpn      = SSUM(iim,xpn,1)/apoln
198 
199            DO ij   = 1, iip1
200              pq (   ij   ,k,iq)  = tpn
201            ENDDO
202          ENDDO
203        ENDDO
204      endif
205     
206      if (pole_sud) then
207        DO iq = 1, nq
208          DO  k    = 1, llm
209            DO  ij   = 1, iim
210              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
211            ENDDO
212            tps      = SSUM(iim,xps,1)/apols
213 
214            DO ij   = 1, iip1
215              pq (ij+ip1jm,k,iq)  = tps
216            ENDDO
217          ENDDO
218        ENDDO
219      endif
220     
221     
222      RETURN
223      END
Note: See TracBrowser for help on using the repository browser.