source: LMDZ5/trunk/libf/dyn3d/fluxstokenc.F @ 3871

Last change on this file since 3871 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
RevLine 
[1279]1!
2! $Id: fluxstokenc.F 2601 2016-07-24 09:51:55Z acozic $
3!
[541]4      SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
5     . time_step,itau )
[1403]6#ifdef CPP_IOIPSL
7! This routine is designed to work with ioipsl
[541]8
9       USE IOIPSL
10c
11c     Auteur :  F. Hourdin
12c
13c
14ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
15c
16      IMPLICIT NONE
17c
[2597]18      include "dimensions.h"
19      include "paramet.h"
20      include "comgeom.h"
21      include "tracstoke.h"
22      include "iniprint.h"
[541]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
[2600]35        real dtcum
[541]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
[697]41      INTEGER, SAVE :: fluxid, fluxvid,fluxdid
[541]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
[697]50
51c AC initialisations
52      pbarug(:,:)   = 0.
53      pbarvg(:,:,:) = 0.
54      wg(:,:)       = 0.
55     
56
[541]57      if(first) then
58
[2600]59        CALL initfluxsto( 'fluxstoke',
[541]60     .  time_step,istdyn* time_step,istdyn* time_step,
[1146]61     .  fluxid,fluxvid,fluxdid)
[2600]62       
63        ndex(1) = 0
[541]64        call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
65        call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
[2600]66       
67        ndex(1) = 0
[541]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)
[2600]75       
76        first = .false.
[541]77
78      endif
79
80
81      IF(iadvtr.EQ.0) THEN
[2239]82         phic(:,:)=0
83         tetac(:,:)=0
84         pbaruc(:,:)=0
85         pbarvc(:,:)=0
[541]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
[1403]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)
[541]116         ENDDO
117         DO ij = 1,ip1jm
[1403]118            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
[541]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
[2600]140        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
141       
142        call histwrite(fluxid, 'masse', itau, massem,
[541]143     .               iip1*jjp1*llm, ndex)
[2600]144       
145        call histwrite(fluxid, 'pbaru', itau, pbarug,
[541]146     .               iip1*jjp1*llm, ndex)
[2600]147       
148        call histwrite(fluxvid, 'pbarv', itau, pbarvg,
[541]149     .               iip1*jjm*llm, ndex)
[2600]150       
[541]151        call histwrite(fluxid, 'w' ,itau, wg,
152     .             iip1*jjp1*llm, ndex)
[2600]153       
154        call histwrite(fluxid, 'teta' ,itau, tetac,
[541]155     .             iip1*jjp1*llm, ndex)
[2600]156       
157        call histwrite(fluxid, 'phi' ,itau, phic,
[541]158     .             iip1*jjp1*llm, ndex)
[2600]159       
[541]160C
161
162      ENDIF ! if iadvtr.EQ.istdyn
163
[1279]164#else
165      write(lunout,*)
[1403]166     & 'fluxstokenc: Needs IOIPSL to function'
[1279]167#endif
[1403]168! of #ifdef CPP_IOIPSL
[541]169      RETURN
170      END
Note: See TracBrowser for help on using the repository browser.