source: LMDZ6/branches/LMDZ-INCA-Dyn/libf/dyn3d/fluxstokenc.F @ 4976

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

Cleanup in the dynamics: turn temps.h into module temps_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: 4.2 KB
Line 
1!
2! $Id: fluxstokenc.F 2601 2016-07-24 09:51:55Z idelkadi $
3!
4      SUBROUTINE fluxstokenc(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
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 "comgeom.h"
21      include "tracstoke.h"
22      include "iniprint.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
50
51c AC initialisations
52      pbarug(:,:)   = 0.
53      pbarvg(:,:,:) = 0.
54      wg(:,:)       = 0.
55     
56
57      if(first) then
58
59        CALL initfluxsto( 'fluxstoke',
60     .  time_step,istdyn* time_step,istdyn* time_step,
61     .  fluxid,fluxvid,fluxdid)
62       
63        ndex(1) = 0
64        call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
65        call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
66       
67        ndex(1) = 0
68        nscal = 1
69        tst(1) = time_step
70        call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
71        ist(1)=istdyn
72        call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
73        istp(1)= istphy
74        call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
75       
76        first = .false.
77
78      endif
79
80
81      IF(iadvtr.EQ.0) THEN
82         phic(:,:)=0
83         tetac(:,:)=0
84         pbaruc(:,:)=0
85         pbarvc(:,:)=0
86      ENDIF
87
88c   accumulation des flux de masse horizontaux
89      DO l=1,llm
90         DO ij = 1,ip1jmp1
91            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
92            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
93            phic(ij,l) = phic(ij,l) + phi(ij,l)
94         ENDDO
95         DO ij = 1,ip1jm
96            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
97         ENDDO
98      ENDDO
99
100c   selection de la masse instantannee des mailles avant le transport.
101      IF(iadvtr.EQ.0) THEN
102         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
103      ENDIF
104
105      iadvtr   = iadvtr+1
106
107
108c   Test pour savoir si on advecte a ce pas de temps
109      IF ( iadvtr.EQ.istdyn ) THEN
110c    normalisation
111      DO l=1,llm
112         DO ij = 1,ip1jmp1
113            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
114            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
115            phic(ij,l) = phic(ij,l)/REAL(istdyn)
116         ENDDO
117         DO ij = 1,ip1jm
118            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
119         ENDDO
120      ENDDO
121
122c   traitement des flux de masse avant advection.
123c     1. calcul de w
124c     2. groupement des mailles pres du pole.
125
126        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
127
128        do l=1,llm
129           do j=1,jjm
130              do i=1,iip1
131                 pbarvst(i,j,l)=pbarvg(i,j,l)
132              enddo
133           enddo
134           do i=1,iip1
135              pbarvst(i,jjp1,l)=0.
136           enddo
137        enddo
138
139         iadvtr=0
140        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
141       
142        call histwrite(fluxid, 'masse', itau, massem,
143     .               iip1*jjp1*llm, ndex)
144       
145        call histwrite(fluxid, 'pbaru', itau, pbarug,
146     .               iip1*jjp1*llm, ndex)
147       
148        call histwrite(fluxvid, 'pbarv', itau, pbarvg,
149     .               iip1*jjm*llm, ndex)
150       
151        call histwrite(fluxid, 'w' ,itau, wg,
152     .             iip1*jjp1*llm, ndex)
153       
154        call histwrite(fluxid, 'teta' ,itau, tetac,
155     .             iip1*jjp1*llm, ndex)
156       
157        call histwrite(fluxid, 'phi' ,itau, phic,
158     .             iip1*jjp1*llm, ndex)
159       
160C
161
162      ENDIF ! if iadvtr.EQ.istdyn
163
164#else
165      write(lunout,*)
166     & 'fluxstokenc: Needs IOIPSL to function'
167#endif
168! of #ifdef CPP_IOIPSL
169      RETURN
170      END
Note: See TracBrowser for help on using the repository browser.