source: LMDZ.3.3/trunk/libf/dyn3d/amont.F @ 19

Last change on this file since 19 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.3 KB
Line 
1      SUBROUTINE amont (nq,iq,q,w, pbaru, pbarv,dq)
2      IMPLICIT NONE
3
4c=======================================================================
5c
6c   Auteur:  P. Le Van / F.Forget
7c   -------
8c
9c   ********************************************************************
10c   Transport d'un traceur q par shema amont 3D
11c   ********************************************************************
12c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
13c     dq               sont des arguments de sortie pour le s-pg ....
14c
15c=======================================================================
16
17
18#include "dimensions.h"
19#include "paramet.h"
20#include "logic.h"
21#include "comvert.h"
22
23c   Arguments:
24c   ----------
25      INTEGER nq,iq 
26      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
27      REAL q(ip1jmp1,llm,nq), dq( ip1jmp1,llm,nq )
28      REAL w(ip1jmp1,llm)
29
30c   Local:
31c   ------
32
33      INTEGER   l,ij
34
35      REAL qbyv( ip1jm,llm ), qbxu( ip1jmp1,llm )
36      REAL ww
37      REAL dqh( ip1jmp1,llm)
38
39      EXTERNAL     convflu
40
41c     ----------------------------------------------------------------
42c     --        calcul transport horiz. pour  dq                    --
43c     -                                                              -
44c     -         shema ' amont '                                      -
45c     ----------------------------------------------------------------
46c
47      IF( iq.GT.2 )   THEN
48       DO   l = 1, llm
49        DO ij = 1, ip1jmp1
50          dq(ij,l,iq) = 0.
51        ENDDO
52       ENDDO
53            RETURN
54      ENDIF
55 
56c
57      IF( forward.OR.leapf )   THEN
58 
59        DO 10 l = 1, llm
60 
61        DO 6  ij     = iip2, ip1jm - 1
62           IF( pbaru(ij,l).GT.0.  )   THEN
63            qbxu( ij,l ) =  pbaru( ij,l )  * q(  ij  ,l,iq)
64           ELSE
65            qbxu( ij,l ) =  pbaru( ij,l )  * q(ij +1 ,l,iq)
66           ENDIF
67   6    CONTINUE
68 
69c     ..... correction  pour  qbxu(iip1,j,l)   .....
70c     ...   qbxu(iip1,j,l)= qbxu(1,j,l)  ...
71 
72CDIR$ IVDEP
73        DO  7   ij   = iip1 +iip1, ip1jm, iip1
74        qbxu( ij,l ) = qbxu( ij - iim, l )
75   7    CONTINUE
76 
77        DO  8  ij     = 1, ip1jm
78           IF( pbarv(ij,l).GT.0.  )   THEN
79            qbyv( ij,l ) =  pbarv( ij,l )  * q(ij+iip1, l,iq)
80           ELSE
81            qbyv( ij,l ) =  pbarv( ij,l )  * q(   ij  , l,iq)
82           ENDIF
83   8    CONTINUE
84c
85  10    CONTINUE
86 
87c     stockage dans  dqh de la convergence horiz.du flux d'humidite  .
88c     -------------------------------------------------------------
89c
90                  CALL  convflu(qbxu, qbyv, llm, dqh )
91
92
93c ---------------------------------------------------------------
94c   .... calcul des termes d'advection vertic.pour q. Shema amont
95c ---------------------------------------------------------------
96
97c     calcul de  - d( q   * w )    qu'on ajoute a  dqh pour calculer dq
98c
99
100       DO 20 l = 1,llmm1
101c
102         DO 11 ij = 1,ip1jmp1
103           IF( w(ij,l+1).LT.0.  )   THEN
104            ww  =   - w( ij,l+1 ) * q( ij,  l  ,iq)
105           ELSE
106            ww  =   - w( ij,l+1 ) * q( ij, l +1,iq)
107           ENDIF
108
109          dq (ij, l ,iq ) = dqh(ij, l )   -  ww
110          dqh(ij,l+1    ) = dqh(ij,l+1)   +  ww
111  11     CONTINUE
112c
113  20   CONTINUE
114
115c
116c       special dq (ij,llm) (qui n'a pas ete rempli ! )
117c
118        DO  ij = 1,ip1jmp1
119          dq( ij,llm,iq ) = dqh( ij,llm )
120        END DO
121           
122      END IF
123
124      RETURN
125      END
Note: See TracBrowser for help on using the repository browser.