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

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

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