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

Last change on this file since 2597 was 2597, checked in by Ehouarn Millour, 8 years ago

Cleanup in the dynamics: get rid of comconst.h, make it a module comconst_mod.
EM
  • 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 2597 2016-07-22 06:44:47Z emillour $
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 "comvert.h"
24#include "comgeom.h"
25#include "tracstoke.h"
26#include "temps.h"
27#include "iniprint.h"
28
29      REAL time_step,t_wrt, t_ops
30      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
31      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
32      REAL phis(ip1jmp1)
33
34      REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
35      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
36
37      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
38
39      REAL pbarvst(iip1,jjp1,llm),zistdyn
40        real dtcum
41
42      INTEGER iadvtr,ndex(1)
43      integer nscal
44      real tst(1),ist(1),istp(1)
45      INTEGER ij,l,irec,i,j,itau
46      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
47 
48      SAVE iadvtr, massem,irec
49      SAVE phic,tetac
50      logical first
51      save first
52      data first/.true./
53      DATA iadvtr/0/
54      integer :: ijb,ije,jjb,jje,jjn
55      type(Request) :: Req
56
57c AC initialisations
58      pbarug(:,:)   = 0.
59cym      pbarvg(:,:,:) = 0.
60cym      wg(:,:)       = 0.
61
62c$OMP MASTER
63
64      if(first) then
65
66        CALL initfluxsto_p( 'fluxstoke',
67     .  time_step,istdyn* time_step,istdyn* time_step,
68     .  fluxid,fluxvid,fluxdid)
69       
70        ijb=ij_begin
71        ije=ij_end
72        jjn=jj_nb
73
74        ndex(1) = 0
75        call histwrite(fluxid, 'phis', 1, phis(ijb:ije),
76     .                 iip1*jjn, ndex)
77        call histwrite(fluxid, 'aire', 1, aire(ijb:ije),
78     .                 iip1*jjn, ndex)
79       
80        ndex(1) = 0
81        nscal = 1
82       
83        if (mpi_rank==0) then
84          tst(1) = time_step
85          call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
86          ist(1)=istdyn
87          call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
88          istp(1)= istphy
89          call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
90        endif
91        first = .false.
92
93      endif
94
95
96      IF(iadvtr.EQ.0) THEN
97cym         CALL initial0(ijp1llm,phic)
98cym        CALL initial0(ijp1llm,tetac)
99cym         CALL initial0(ijp1llm,pbaruc)
100cym         CALL initial0(ijmllm,pbarvc)
101        ijb=ij_begin
102        ije=ij_end
103        phic(ijb:ije,1:llm)=0
104        tetac(ijb:ije,1:llm)=0
105        pbaruc(ijb:ije,1:llm)=0
106       
107        IF (pole_sud) ije=ij_end-iip1
108        pbarvc(ijb:ije,1:llm)=0
109      ENDIF
110
111c   accumulation des flux de masse horizontaux
112      ijb=ij_begin
113      ije=ij_end
114     
115      DO l=1,llm
116         DO ij = ijb,ije
117            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
118            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
119            phic(ij,l) = phic(ij,l) + phi(ij,l)
120         ENDDO
121       ENDDO
122     
123      ijb=ij_begin
124      ije=ij_end
125      if (pole_sud) ije=ij_end-iip1
126       
127      DO l=1,llm
128         DO ij = ijb,ije
129            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
130         ENDDO
131      ENDDO
132
133c   selection de la masse instantannee des mailles avant le transport.
134      IF(iadvtr.EQ.0) THEN
135cym         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
136        ijb=ij_begin
137        ije=ij_end
138        massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
139      ENDIF
140
141      iadvtr   = iadvtr+1
142
143c$OMP END MASTER
144c$OMP BARRIER
145c   Test pour savoir si on advecte a ce pas de temps
146      IF ( iadvtr.EQ.istdyn ) THEN
147c$OMP MASTER
148c    normalisation
149      ijb=ij_begin
150      ije=ij_end
151
152      DO l=1,llm
153         DO ij = ijb,ije
154            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
155            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
156            phic(ij,l) = phic(ij,l)/REAL(istdyn)
157         ENDDO
158      ENDDO
159
160      ijb=ij_begin
161      ije=ij_end
162      if (pole_sud) ije=ij_end-iip1     
163     
164      DO l=1,llm
165          DO ij = ijb,ije
166            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
167         ENDDO
168      ENDDO
169
170c   traitement des flux de masse avant advection.
171c     1. calcul de w
172c     2. groupement des mailles pres du pole.
173c$OMP END MASTER
174c$OMP BARRIER
175        call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req)
176        call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req)
177        call SendRequest(Req)
178c$OMP BARRIER
179        call WaitRequest(Req)
180c$OMP BARRIER
181c$OMP MASTER
182        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
183       
184        jjb=jj_begin
185        jje=jj_end
186        if (pole_sud) jje=jj_end-1
187       
188        do l=1,llm
189           do j=jjb,jje
190              do i=1,iip1
191                 pbarvst(i,j,l)=pbarvg(i,j,l)
192              enddo
193           enddo
194         enddo
195         
196         if (pole_sud) then
197           do i=1,iip1
198              pbarvst(i,jjp1,l)=0.
199           enddo
200        endif
201     
202         iadvtr=0
203        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
204       
205        ijb=ij_begin
206        ije=ij_end
207        jjn=jj_nb
208       
209        call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:),
210     .               iip1*jjn*llm, ndex)
211       
212        call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:),
213     .               iip1*jjn*llm, ndex)
214       
215        jjb=jj_begin
216        jje=jj_end
217        jjn=jj_nb
218        if (pole_sud) then
219          jje=jj_end-1
220          jjn=jj_nb-1
221        endif
222       
223        call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:),
224     .               iip1*jjn*llm, ndex)
225       
226        ijb=ij_begin
227        ije=ij_end
228        jjn=jj_nb
229       
230        call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:),
231     .             iip1*jjn*llm, ndex)
232       
233        call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:),
234     .             iip1*jjn*llm, ndex)
235       
236        call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:),
237     .             iip1*jjn*llm, ndex)
238       
239C
240c$OMP END MASTER
241      ENDIF ! if iadvtr.EQ.istdyn
242
243#else
244      write(lunout,*)
245     & 'fluxstokenc: Needs IOIPSL to function'
246#endif
247! of #ifdef CPP_IOIPSL
248      RETURN
249      END
Note: See TracBrowser for help on using the repository browser.