source: LMDZ4/trunk/libf/dyn3dpar/addfi_p.F @ 3400

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

Réintegration dans le tronc des modifications issues de la branche LMDZ-dev
comprises entre la révision 1074 et 1145
Validation: une simulation de 1 jour en séquentiel sur PC donne les mêmes
résultats entre la trunk et la dev
LF

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.5 KB
RevLine 
[774]1!
2! $Header$
3!
[1146]4      SUBROUTINE addfi_p(pdt, leapf, forward,
[630]5     S          pucov, pvcov, pteta, pq   , pps ,
6     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
7      USE parallel
[1146]8      USE infotrac, ONLY : nqtot
[630]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)
[1146]59      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1)
[630]60c
61      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
[1146]62      REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
[630]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     
[764]86c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
[630]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
[764]92c$OMP END DO NOWAIT
[630]93
94      if (pole_nord) then
[764]95c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]106c$OMP END DO NOWAIT
[630]107      endif
108
109      if (pole_sud) then
[764]110c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]121c$OMP END DO NOWAIT
[630]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
[764]129
130c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]136c$OMP END DO NOWAIT
[630]137
138      if (pole_nord) ijb=ij_begin
139
[764]140c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]146c$OMP END DO NOWAIT
[630]147
148c
149      if (pole_sud)  ije=ij_end
[764]150c$OMP MASTER
[630]151      DO j = ijb,ije
152         pps(j) = pps(j) + pdpfi(j) * pdt
153      ENDDO
[764]154c$OMP END MASTER
[630]155 
156      DO iq = 1, 2
[764]157c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]164c$OMP END DO NOWAIT
[630]165      ENDDO
166
[1146]167      DO iq = 3, nqtot
[764]168c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]175c$OMP END DO NOWAIT
[630]176      ENDDO
177
[764]178c$OMP MASTER
[630]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
[764]206c$OMP END MASTER
[630]207
208      if (pole_nord) then
[1146]209        DO iq = 1, nqtot
[764]210c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]221c$OMP END DO NOWAIT       
[630]222        ENDDO
223      endif
224     
225      if (pole_sud) then
[1146]226        DO iq = 1, nqtot
[764]227c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]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
[764]238c$OMP END DO NOWAIT       
[630]239        ENDDO
240      endif
241     
242     
243      RETURN
244      END
Note: See TracBrowser for help on using the repository browser.