source: LMDZ5/branches/AI-cosp/libf/dyn3d/fluxstokenc.F @ 2720

Last change on this file since 2720 was 2239, checked in by Ehouarn Millour, 10 years ago

Reorganizing physics/dynamics interface:

  • what is related to dynamics-physics interface is now in a seperate directory: dynlmdz_phy* for physics in phy*
  • 1d model and related dependencies (including a couple from "dynamics", set up as symbolic links) is now in subdirectory "dyn1d" of phy*.
  • "bibio" directory is now "misc" and should only contain autonomous utilities.
  • "cosp" is now a subdirectory of phylmd.

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.1 KB
Line 
1!
2! $Id: fluxstokenc.F 2239 2015-03-23 07:27:30Z fairhead $
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 "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         phic(:,:)=0
86         tetac(:,:)=0
87         pbaruc(:,:)=0
88         pbarvc(:,:)=0
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)/REAL(istdyn)
117            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
118            phic(ij,l) = phic(ij,l)/REAL(istdyn)
119         ENDDO
120         DO ij = 1,ip1jm
121            pbarvc(ij,l) = pbarvc(ij,l)/REAL(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        write(lunout,*)'ITAU auquel 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 IOIPSL to function'
170#endif
171! of #ifdef CPP_IOIPSL
172      RETURN
173      END
Note: See TracBrowser for help on using the repository browser.