source: LMDZ5/trunk/libf/dyn3dpar/fluxstokenc_p.F @ 2438

Last change on this file since 2438 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.7 KB
Line 
1!
2! $Id: fluxstokenc_p.F 1907 2013-11-26 13:10:46Z lguez $
3!
4      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
5     . time_step,itau )
6#ifdef CPP_IOIPSL
7! This routine is designed to work with ioipsl
8
9       USE IOIPSL
10       USE parallel_lmdz
11       USE misc_mod
12       USE mod_hallo
13c
14c     Auteur :  F. Hourdin
15c
16c
17ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
18c
19      IMPLICIT NONE
20c
21#include "dimensions.h"
22#include "paramet.h"
23#include "comconst.h"
24#include "comvert.h"
25#include "comgeom.h"
26#include "tracstoke.h"
27#include "temps.h"
28#include "iniprint.h"
29
30      REAL time_step,t_wrt, t_ops
31      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
32      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
33      REAL phis(ip1jmp1)
34
35      REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
36      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
37
38      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
39
40      REAL pbarvst(iip1,jjp1,llm),zistdyn
41        real dtcum
42
43      INTEGER iadvtr,ndex(1)
44      integer nscal
45      real tst(1),ist(1),istp(1)
46      INTEGER ij,l,irec,i,j,itau
47      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
48 
49      SAVE iadvtr, massem,irec
50      SAVE phic,tetac
51      logical first
52      save first
53      data first/.true./
54      DATA iadvtr/0/
55      integer :: ijb,ije,jjb,jje,jjn
56      type(Request) :: Req
57
58c AC initialisations
59      pbarug(:,:)   = 0.
60cym      pbarvg(:,:,:) = 0.
61cym      wg(:,:)       = 0.
62
63c$OMP MASTER
64
65      if(first) then
66
67        CALL initfluxsto_p( 'fluxstoke',
68     .  time_step,istdyn* time_step,istdyn* time_step,
69     .  fluxid,fluxvid,fluxdid)
70       
71        ijb=ij_begin
72        ije=ij_end
73        jjn=jj_nb
74
75        ndex(1) = 0
76        call histwrite(fluxid, 'phis', 1, phis(ijb:ije),
77     .                 iip1*jjn, ndex)
78        call histwrite(fluxid, 'aire', 1, aire(ijb:ije),
79     .                 iip1*jjn, ndex)
80       
81        ndex(1) = 0
82        nscal = 1
83       
84        if (mpi_rank==0) then
85          tst(1) = time_step
86          call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
87          ist(1)=istdyn
88          call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
89          istp(1)= istphy
90          call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
91        endif
92        first = .false.
93
94      endif
95
96
97      IF(iadvtr.EQ.0) THEN
98cym         CALL initial0(ijp1llm,phic)
99cym        CALL initial0(ijp1llm,tetac)
100cym         CALL initial0(ijp1llm,pbaruc)
101cym         CALL initial0(ijmllm,pbarvc)
102        ijb=ij_begin
103        ije=ij_end
104        phic(ijb:ije,1:llm)=0
105        tetac(ijb:ije,1:llm)=0
106        pbaruc(ijb:ije,1:llm)=0
107       
108        IF (pole_sud) ije=ij_end-iip1
109        pbarvc(ijb:ije,1:llm)=0
110      ENDIF
111
112c   accumulation des flux de masse horizontaux
113      ijb=ij_begin
114      ije=ij_end
115     
116      DO l=1,llm
117         DO ij = ijb,ije
118            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
119            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
120            phic(ij,l) = phic(ij,l) + phi(ij,l)
121         ENDDO
122       ENDDO
123     
124      ijb=ij_begin
125      ije=ij_end
126      if (pole_sud) ije=ij_end-iip1
127       
128      DO l=1,llm
129         DO ij = ijb,ije
130            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
131         ENDDO
132      ENDDO
133
134c   selection de la masse instantannee des mailles avant le transport.
135      IF(iadvtr.EQ.0) THEN
136cym         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
137        ijb=ij_begin
138        ije=ij_end
139        massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
140      ENDIF
141
142      iadvtr   = iadvtr+1
143
144c$OMP END MASTER
145c$OMP BARRIER
146c   Test pour savoir si on advecte a ce pas de temps
147      IF ( iadvtr.EQ.istdyn ) THEN
148c$OMP MASTER
149c    normalisation
150      ijb=ij_begin
151      ije=ij_end
152
153      DO l=1,llm
154         DO ij = ijb,ije
155            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
156            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
157            phic(ij,l) = phic(ij,l)/REAL(istdyn)
158         ENDDO
159      ENDDO
160
161      ijb=ij_begin
162      ije=ij_end
163      if (pole_sud) ije=ij_end-iip1     
164     
165      DO l=1,llm
166          DO ij = ijb,ije
167            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
168         ENDDO
169      ENDDO
170
171c   traitement des flux de masse avant advection.
172c     1. calcul de w
173c     2. groupement des mailles pres du pole.
174c$OMP END MASTER
175c$OMP BARRIER
176        call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req)
177        call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req)
178        call SendRequest(Req)
179c$OMP BARRIER
180        call WaitRequest(Req)
181c$OMP BARRIER
182c$OMP MASTER
183        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
184       
185        jjb=jj_begin
186        jje=jj_end
187        if (pole_sud) jje=jj_end-1
188       
189        do l=1,llm
190           do j=jjb,jje
191              do i=1,iip1
192                 pbarvst(i,j,l)=pbarvg(i,j,l)
193              enddo
194           enddo
195         enddo
196         
197         if (pole_sud) then
198           do i=1,iip1
199              pbarvst(i,jjp1,l)=0.
200           enddo
201        endif
202     
203         iadvtr=0
204        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
205       
206        ijb=ij_begin
207        ije=ij_end
208        jjn=jj_nb
209       
210        call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:),
211     .               iip1*jjn*llm, ndex)
212       
213        call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:),
214     .               iip1*jjn*llm, ndex)
215       
216        jjb=jj_begin
217        jje=jj_end
218        jjn=jj_nb
219        if (pole_sud) then
220          jje=jj_end-1
221          jjn=jj_nb-1
222        endif
223       
224        call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:),
225     .               iip1*jjn*llm, ndex)
226       
227        ijb=ij_begin
228        ije=ij_end
229        jjn=jj_nb
230       
231        call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:),
232     .             iip1*jjn*llm, ndex)
233       
234        call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:),
235     .             iip1*jjn*llm, ndex)
236       
237        call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:),
238     .             iip1*jjn*llm, ndex)
239       
240C
241c$OMP END MASTER
242      ENDIF ! if iadvtr.EQ.istdyn
243
244#else
245      write(lunout,*)
246     & 'fluxstokenc: Needs IOIPSL to function'
247#endif
248! of #ifdef CPP_IOIPSL
249      RETURN
250      END
Note: See TracBrowser for help on using the repository browser.