source: LMDZ4/branches/V3_test/libf/dyn3dpar/fluxstokenc_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.4 KB
Line 
1      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
2     . time_step,itau )
3
4       USE IOIPSL
5       USE parallel
6       USE misc_mod
7       USE mod_hallo
8c
9c     Auteur :  F. Hourdin
10c
11c
12ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
13c
14      IMPLICIT NONE
15c
16#include "dimensions.h"
17#include "paramet.h"
18#include "comconst.h"
19#include "comvert.h"
20#include "comgeom.h"
21#include "tracstoke.h"
22#include "temps.h"
23
24      REAL time_step,t_wrt, t_ops
25      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
26      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
27      REAL phis(ip1jmp1)
28
29      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
30      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
31
32      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
33
34      REAL pbarvst(iip1,jjp1,llm),zistdyn
35        real dtcum
36
37      INTEGER iadvtr,ndex(1)
38      integer nscal
39      real tst(1),ist(1),istp(1)
40      INTEGER ij,l,irec,i,j,itau
41      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
42 
43      SAVE iadvtr, massem,pbaruc,pbarvc,irec
44      SAVE phic,tetac
45      logical first
46      save first
47      data first/.true./
48      DATA iadvtr/0/
49      integer :: ijb,ije,jjb,jje,jjn
50      type(Request) :: Req
51
52c AC initialisations
53cym      pbarug(:,:)   = 0.
54cym      pbarvg(:,:,:) = 0.
55cym      wg(:,:)       = 0.
56
57      if(first) then
58
59        CALL initfluxsto_p( 'fluxstoke',
60     .  time_step,istdyn* time_step,istdyn* time_step,
61     . nqmx, fluxid,fluxvid,fluxdid)
62       
63        ijb=ij_begin
64        ije=ij_end
65        jjn=jj_nb
66
67        ndex(1) = 0
68        call histwrite(fluxid, 'phis', 1, phis(ijb:ije),
69     .                 iip1*jjn, ndex)
70        call histwrite(fluxid, 'aire', 1, aire(ijb:ije),
71     .                 iip1*jjn, ndex)
72       
73        ndex(1) = 0
74        nscal = 1
75       
76        if (mpi_rank==0) then
77          tst(1) = time_step
78          call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
79          ist(1)=istdyn
80          call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
81          istp(1)= istphy
82          call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
83        endif
84        first = .false.
85
86      endif
87
88
89      IF(iadvtr.EQ.0) THEN
90cym         CALL initial0(ijp1llm,phic)
91cym        CALL initial0(ijp1llm,tetac)
92cym         CALL initial0(ijp1llm,pbaruc)
93cym         CALL initial0(ijmllm,pbarvc)
94        ijb=ij_begin
95        ije=ij_end
96        phic(ijb:ije,1:llm)=0
97        tetac(ijb:ije,1:llm)=0
98        pbaruc(ijb:ije,1:llm)=0
99       
100        if (pole_sud) ije=ij_end-iip1
101        pbarvc(ijb:ije,1:llm)=0
102      ENDIF
103
104c   accumulation des flux de masse horizontaux
105      ijb=ij_begin
106      ije=ij_end
107     
108      DO l=1,llm
109         DO ij = ijb,ije
110            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
111            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
112            phic(ij,l) = phic(ij,l) + phi(ij,l)
113         ENDDO
114       ENDDO
115     
116      ijb=ij_begin
117      ije=ij_end
118      if (pole_sud) ije=ij_end-iip1
119       
120      DO l=1,llm
121         DO ij = ijb,ije
122            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
123         ENDDO
124      ENDDO
125
126c   selection de la masse instantannee des mailles avant le transport.
127      IF(iadvtr.EQ.0) THEN
128cym         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
129        ijb=ij_begin
130        ije=ij_end
131        massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
132      ENDIF
133
134      iadvtr   = iadvtr+1
135
136
137c   Test pour savoir si on advecte a ce pas de temps
138      IF ( iadvtr.EQ.istdyn ) THEN
139c    normalisation
140      ijb=ij_begin
141      ije=ij_end
142
143      DO l=1,llm
144         DO ij = ijb,ije
145            pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
146            tetac(ij,l) = tetac(ij,l)/float(istdyn)
147            phic(ij,l) = phic(ij,l)/float(istdyn)
148         ENDDO
149      ENDDO
150
151      ijb=ij_begin
152      ije=ij_end
153      if (pole_sud) ije=ij_end-iip1     
154     
155      DO l=1,llm
156          DO ij = ijb,ije
157            pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
158         ENDDO
159      ENDDO
160
161c   traitement des flux de masse avant advection.
162c     1. calcul de w
163c     2. groupement des mailles pres du pole.
164
165        call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req)
166        call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req)
167        call SendRequest(Req)
168        call WaitRequest(Req)
169
170        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
171       
172        jjb=jj_begin
173        jje=jj_end
174        if (pole_sud) jje=jj_end-1
175       
176        do l=1,llm
177           do j=jjb,jje
178              do i=1,iip1
179                 pbarvst(i,j,l)=pbarvg(i,j,l)
180              enddo
181           enddo
182         enddo
183         
184         if (pole_sud) then
185           do i=1,iip1
186              pbarvst(i,jjp1,l)=0.
187           enddo
188        endif
189     
190         iadvtr=0
191        Print*,'ITAU auqel on stoke les fluxmasses',itau
192       
193        ijb=ij_begin
194        ije=ij_end
195        jjn=jj_nb
196       
197        call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:),
198     .               iip1*jjn*llm, ndex)
199       
200        call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:),
201     .               iip1*jjn*llm, ndex)
202       
203        jjb=jj_begin
204        jje=jj_end
205        jjn=jj_nb
206        if (pole_sud) then
207          jje=jj_end-1
208          jjn=jj_nb-1
209        endif
210       
211        call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:),
212     .               iip1*jjn*llm, ndex)
213       
214        ijb=ij_begin
215        ije=ij_end
216        jjn=jj_nb
217       
218        call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:),
219     .             iip1*jjn*llm, ndex)
220       
221        call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:),
222     .             iip1*jjn*llm, ndex)
223       
224        call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:),
225     .             iip1*jjn*llm, ndex)
226       
227C
228
229      ENDIF ! if iadvtr.EQ.istdyn
230
231      RETURN
232      END
Note: See TracBrowser for help on using the repository browser.