source: trunk/LMDZ.COMMON/libf/dyn3d/fluxstokenc.F @ 2919

Last change on this file since 2919 was 1441, checked in by emillour, 9 years ago

Updates in common dynamics (seq and ) to keep up with updates
in LMDZ5 (up to LMDZ5 trunk, rev 2250):

  • compilation:
  • added test in grid/dimension/makdim to check that # of longitudes is a multiple of 8
  • dyn3d_common:

Bug correction concerning zoom (cf LMDZ5 rev 2218)

  • coefpoly.F becomes coefpoly_m.F90 (in misc)
  • fxhyp.F => fxhyp_m.F90 , fyhyp.F => fyhyp_m.F90
  • new routines for zoom: invert_zoom_x_m.F90 and principal_cshift_m.F90
  • inigeom.F adapted to new zoom definition routines
  • fluxstokenc.F : got rid of calls to initial0()
  • dyn3d:
  • advtrac.F90 : got rid of calls to initial0()
  • conf_gcm.F90 : cosmetic changes and change in default dzoomx,dzoomy values
  • guide_mod.F90 : followed updates from Earth Model
  • gcm.F is now gcm.F90
  • dyn3dpar:
  • advtrac_p.F90, covcont_p.F90, mod_hallo.F90 : cosmetic changes
  • conf_gcm.F90 : cosmetic and changed in default dzoomx,dzoomy values
  • parallel_lmdz.F90 : updates to keep up with Earth model
  • misc:
  • arth.F90 becomes arth_m.F90
  • wxios.F90 updated wrt Earth model changes
  • nrtype.F90 and coefpoly_m.F90 added
  • ran1.F, sort.F, minmax.F, minmax2.F, juldate.F moved over from dyn3d_common

EM

File size: 4.1 KB
RevLine 
[1]1!
2! $Id: fluxstokenc.F 1403 2010-07-01 09:02:53Z 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 "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
[1441]82         phic(:,:)=0
83         tetac(:,:)=0
84         pbaruc(:,:)=0
85         pbarvc(:,:)=0
[1]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.