source: LMDZ.3.3/branches/LF/libf/dyn3d/addfi.F @ 3

Last change on this file since 3 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.8 KB
Line 
1      SUBROUTINE addfi(nq, pdt, leapf, forward,
2     S          pucov, pvcov, pteta, pq   , pps ,
3     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
4      IMPLICIT NONE
5c
6c=======================================================================
7c
8c    Addition of the physical tendencies
9c
10c    Interface :
11c    -----------
12c
13c      Input :
14c      -------
15c      pdt                    time step of integration
16c      leapf                  logical
17c      forward                logical
18c      pucov(ip1jmp1,llm)     first component of the covariant velocity
19c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
20c      pteta(ip1jmp1,llm)     potential temperature
21c      pts(ip1jmp1,llm)       surface temperature
22c      pdufi(ip1jmp1,llm)     |
23c      pdvfi(ip1jm,llm)       |   respective
24c      pdhfi(ip1jmp1)         |      tendencies
25c      pdtsfi(ip1jmp1)        |
26c
27c      Output :
28c      --------
29c      pucov
30c      pvcov
31c      ph
32c      pts
33c
34c
35c=======================================================================
36c
37c-----------------------------------------------------------------------
38c
39c    0.  Declarations :
40c    ------------------
41c
42#include "dimensions.h"
43#include "paramet.h"
44#include "comconst.h"
45#include "comgeom.h"
46#include "serre.h"
47c
48c    Arguments :
49c    -----------
50c
51      INTEGER nq
52
53      REAL pdt
54c
55      REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
56      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)
57c
58      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
59      REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
60c
61      LOGICAL leapf,forward
62c
63c
64c    Local variables :
65c    -----------------
66c
67      REAL xpn(iim),xps(iim),tpn,tps
68      INTEGER j,k,iq,ij
69      REAL qtest
70      PARAMETER ( qtest = 1.0e-30 )
71
72      REAL SSUM
73      EXTERNAL SSUM
74c
75c-----------------------------------------------------------------------
76
77      DO k = 1,llm
78         DO j = 1,ip1jmp1
79            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
80         ENDDO
81      ENDDO
82
83      IF( alphax.NE.0. )   THEN
84        DO  k    = 1, llm
85         DO  ij   = 1, iim
86          xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
87          xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
88         ENDDO
89          tpn      = SSUM(iim,xpn,1)/ apoln
90          tps      = SSUM(iim,xps,1)/ apols
91
92         DO ij   = 1, iip1
93          pteta(   ij   ,k)  = tpn
94          pteta(ij+ip1jm,k)  = tps
95         ENDDO
96        ENDDO
97      ENDIF
98c
99
100      DO k = 1,llm
101         DO j = iip2,ip1jm
102            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
103         ENDDO
104      ENDDO
105
106      DO k = 1,llm
107         DO j = 1,ip1jm
108            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
109         ENDDO
110      ENDDO
111
112c
113      DO j = 1,ip1jmp1
114         pps(j) = pps(j) + pdpfi(j) * pdt
115      ENDDO
116
117c
118
119      DO iq = 1, nq
120         DO k = 1,llm
121            DO j = 1,ip1jmp1
122               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
123               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtest )
124ccc              pq(j,k,iq)=qtest
125            ENDDO
126         ENDDO
127      ENDDO
128
129
130      IF( alphax.NE.0. )   THEN
131
132         DO  ij   = 1, iim
133          xpn(ij) = aire(   ij   ) * pps(  ij     )
134          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
135         ENDDO
136          tpn      = SSUM(iim,xpn,1)/apoln
137          tps      = SSUM(iim,xps,1)/apols
138
139         DO ij   = 1, iip1
140          pps (   ij     )  = tpn
141          pps ( ij+ip1jm )  = tps
142         ENDDO
143
144
145       DO iq = 1, nq
146         DO  k    = 1, llm
147           DO  ij   = 1, iim
148            xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
149            xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
150           ENDDO
151            tpn      = SSUM(iim,xpn,1)/apoln
152            tps      = SSUM(iim,xps,1)/apols
153
154           DO ij   = 1, iip1
155            pq (   ij   ,k,iq)  = tpn
156            pq (ij+ip1jm,k,iq)  = tps
157           ENDDO
158         ENDDO
159       ENDDO
160
161      ENDIF
162
163
164      RETURN
165      END
Note: See TracBrowser for help on using the repository browser.