source: LMDZ.3.3/branches/LF/libf/dyn3d/fluxstoke.F @ 5007

Last change on this file since 5007 was 2, checked in by lmdz, 25 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 3.9 KB
Line 
1      SUBROUTINE fluxstoke(pbaru,pbarv,masse,teta,phi,phis)
2c
3c     Auteur :  F. Hourdin
4c
5c
6ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
7c
8      IMPLICIT NONE
9c
10#include "dimensions.h"
11#include "paramet.h"
12#include "comconst.h"
13#include "comvert.h"
14#include "comgeom.h"
15#include "tracstoke.h"
16
17
18      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
19      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
20      REAL phis(ip1jmp1)
21
22      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
23      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
24
25      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
26
27      REAL pbarvst(iip1,jjp1,llm)
28
29
30      INTEGER iadvtr
31      INTEGER ij,l,irec,i,j
32 
33      SAVE iadvtr, massem,pbaruc,pbarvc,irec
34      SAVE phic,tetac
35      logical first
36      save first
37      data first/.true./
38      DATA iadvtr/0/
39
40      if(first) then
41#ifdef CRAY
42         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
43#endif
44         open(47,file='fluxmass',form='unformatted',
45     s        access='direct',recl=4*(6*ijp1llm))
46         irec=1
47         first=.false.
48
49         open(77,file='fluxmass.ctl',status='unknown',form='formatted')
50
51      endif
52
53
54      IF(iadvtr.EQ.0) THEN
55         CALL initial0(ijp1llm,phic)
56         CALL initial0(ijp1llm,tetac)
57         CALL initial0(ijp1llm,pbaruc)
58         CALL initial0(ijmllm,pbarvc)
59      ENDIF
60
61c   accumulation des flux de masse horizontaux
62      DO l=1,llm
63         DO ij = 1,ip1jmp1
64            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
65            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
66            phic(ij,l) = phic(ij,l) + phi(ij,l)
67         ENDDO
68         DO ij = 1,ip1jm
69            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
70         ENDDO
71      ENDDO
72
73c   selection de la masse instantannee des mailles avant le transport.
74      IF(iadvtr.EQ.0) THEN
75         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
76      ENDIF
77
78      iadvtr   = iadvtr+1
79
80
81c   Test pour savoir si on advecte a ce pas de temps
82      IF ( iadvtr.EQ.istdyn ) THEN
83
84c    normalisation
85      DO l=1,llm
86         DO ij = 1,ip1jmp1
87            pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
88            tetac(ij,l) = tetac(ij,l)/float(istdyn)
89            phic(ij,l) = phic(ij,l)/float(istdyn)
90         ENDDO
91         DO ij = 1,ip1jm
92            pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
93         ENDDO
94      ENDDO
95
96c   traitement des flux de masse avant advection.
97c     1. calcul de w
98c     2. groupement des mailles pres du pole.
99
100        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
101
102        do l=1,llm
103           do j=1,jjm
104              do i=1,iip1
105                 pbarvst(i,j,l)=pbarvg(i,j,l)
106              enddo
107           enddo
108           do i=1,iip1
109              pbarvst(i,jjp1,l)=0.
110           enddo
111        enddo
112
113         iadvtr=0
114
115         irec=irec+1
116         write(47,rec=1) float(irec),dtvr,float(istdyn),
117     s    float(iim),float(jjm),float(llm),rlonu,rlonv,rlatu,rlatv
118     s    ,aire,phis
119         write(47,rec=irec) massem,pbarug,pbarvst,wg,tetac,phic
120
121c   on reinitialise a zero les flux de masse cumules.
122
123      write(77,'(a4,2x,a40)')
124     &       'DSET ','^fluxmass'
125
126      write(77,'(a12)') 'UNDEF 1.0E30'
127      write(77,'(a5,1x,a40)') 'TITLE ','Titre a voir'
128      call formcoord(77,iip1,rlonv,180./pi,.false.,'XDEF')
129      call formcoord(77,jjp1,rlatu,180./pi,.true.,'YDEF')
130      call formcoord(77,llm,presnivs,1.,.false.,'ZDEF')
131      write(77,'(a4,i10,a30)')
132     &       'TDEF ',irec,' LINEAR 02JAN1987 1DY '
133      write(77,'(a4,2x,i5)') 'VARS',6
134      write(77,1000) 'masse',llm,99,'masse    '
135      write(77,1000) 'pbaru',llm,99,'pbaru    '
136      write(77,1000) 'pbarv',llm,99,'pbarv    '
137      write(77,1000) 'w    ',llm,99,'w        '
138      write(77,1000) 'teta ',llm,99,'teta     '
139      write(77,1000) 'phi  ',llm,99,'phi      '
140      write(77,'(a7)') 'ENDVARS'
141
1421000  format(a5,3x,i4,i3,1x,a39)
143
144
145
146      ENDIF ! if iadvtr.EQ.istdyn
147
148      RETURN
149      END
Note: See TracBrowser for help on using the repository browser.