source: LMDZ.3.3/trunk/libf/dyn3d/fluxstokenc.F @ 182

Last change on this file since 182 was 55, checked in by lmdzadmin, 25 years ago

Ecriture des fichiers de fluxs 'offline'en netcdf/ioipsl. M. Bonazzola
Lf

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