source: LMDZ4/branches/LMDZ4_AR5/libf/dyn3d/fluxstokenc.F @ 5023

Last change on this file since 5023 was 1279, checked in by Laurent Fairhead, 15 years ago

Merged LMDZ4-dev branch changes r1241:1278 into the trunk
Running trunk and LMDZ4-dev in LMDZOR configuration on local
machine (sequential) and SX8 (4-proc) yields identical results
(restart and restartphy are identical binarily)
Log history from r1241 to r1278 is available by switching to
source:LMDZ4/branches/LMDZ4-dev-20091210

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.2 KB
Line 
1!
2! $Id: fluxstokenc.F 1279 2009-12-10 09:02:56Z snguyen $
3!
4      SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
5     . time_step,itau )
6#ifdef CPP_EARTH
7! This routine is designed to work for Earth and with ioipsl
8
9       USE IOIPSL
10c
11c     Auteur :  F. Hourdin
12c
13c
14ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
15c
16      IMPLICIT NONE
17c
18#include "dimensions.h"
19#include "paramet.h"
20#include "comconst.h"
21#include "comvert.h"
22#include "comgeom.h"
23#include "tracstoke.h"
24#include "temps.h"
25#include "iniprint.h"
26
27      REAL time_step,t_wrt, t_ops
28      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
29      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
30      REAL phis(ip1jmp1)
31
32      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
33      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
34
35      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
36
37      REAL pbarvst(iip1,jjp1,llm),zistdyn
38        real dtcum
39
40      INTEGER iadvtr,ndex(1)
41      integer nscal
42      real tst(1),ist(1),istp(1)
43      INTEGER ij,l,irec,i,j,itau
44      INTEGER, SAVE :: fluxid, fluxvid,fluxdid
45 
46      SAVE iadvtr, massem,pbaruc,pbarvc,irec
47      SAVE phic,tetac
48      logical first
49      save first
50      data first/.true./
51      DATA iadvtr/0/
52
53
54c AC initialisations
55      pbarug(:,:)   = 0.
56      pbarvg(:,:,:) = 0.
57      wg(:,:)       = 0.
58     
59
60      if(first) then
61
62        CALL initfluxsto( 'fluxstoke',
63     .  time_step,istdyn* time_step,istdyn* time_step,
64     .  fluxid,fluxvid,fluxdid)
65       
66        ndex(1) = 0
67        call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
68        call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
69       
70        ndex(1) = 0
71        nscal = 1
72        tst(1) = time_step
73        call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
74        ist(1)=istdyn
75        call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
76        istp(1)= istphy
77        call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
78       
79        first = .false.
80
81      endif
82
83
84      IF(iadvtr.EQ.0) THEN
85         CALL initial0(ijp1llm,phic)
86         CALL initial0(ijp1llm,tetac)
87         CALL initial0(ijp1llm,pbaruc)
88         CALL initial0(ijmllm,pbarvc)
89      ENDIF
90
91c   accumulation des flux de masse horizontaux
92      DO l=1,llm
93         DO ij = 1,ip1jmp1
94            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
95            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
96            phic(ij,l) = phic(ij,l) + phi(ij,l)
97         ENDDO
98         DO ij = 1,ip1jm
99            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
100         ENDDO
101      ENDDO
102
103c   selection de la masse instantannee des mailles avant le transport.
104      IF(iadvtr.EQ.0) THEN
105         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
106      ENDIF
107
108      iadvtr   = iadvtr+1
109
110
111c   Test pour savoir si on advecte a ce pas de temps
112      IF ( iadvtr.EQ.istdyn ) THEN
113c    normalisation
114      DO l=1,llm
115         DO ij = 1,ip1jmp1
116            pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
117            tetac(ij,l) = tetac(ij,l)/float(istdyn)
118            phic(ij,l) = phic(ij,l)/float(istdyn)
119         ENDDO
120         DO ij = 1,ip1jm
121            pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
122         ENDDO
123      ENDDO
124
125c   traitement des flux de masse avant advection.
126c     1. calcul de w
127c     2. groupement des mailles pres du pole.
128
129        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
130
131        do l=1,llm
132           do j=1,jjm
133              do i=1,iip1
134                 pbarvst(i,j,l)=pbarvg(i,j,l)
135              enddo
136           enddo
137           do i=1,iip1
138              pbarvst(i,jjp1,l)=0.
139           enddo
140        enddo
141
142         iadvtr=0
143        Print*,'ITAU auqel on stoke les fluxmasses',itau
144       
145        call histwrite(fluxid, 'masse', itau, massem,
146     .               iip1*jjp1*llm, ndex)
147       
148        call histwrite(fluxid, 'pbaru', itau, pbarug,
149     .               iip1*jjp1*llm, ndex)
150       
151        call histwrite(fluxvid, 'pbarv', itau, pbarvg,
152     .               iip1*jjm*llm, ndex)
153       
154        call histwrite(fluxid, 'w' ,itau, wg,
155     .             iip1*jjp1*llm, ndex)
156       
157        call histwrite(fluxid, 'teta' ,itau, tetac,
158     .             iip1*jjp1*llm, ndex)
159       
160        call histwrite(fluxid, 'phi' ,itau, phic,
161     .             iip1*jjp1*llm, ndex)
162       
163C
164
165      ENDIF ! if iadvtr.EQ.istdyn
166
167#else
168      write(lunout,*)
169     & 'fluxstokenc: Needs Earth physics (and ioipsl) to function'
170#endif
171! of #ifdef CPP_EARTH
172      RETURN
173      END
Note: See TracBrowser for help on using the repository browser.