My Project
 All Classes Files Functions Variables Macros
addfi.F
Go to the documentation of this file.
1 !
2 ! $Id: addfi.F 1454 2010-11-18 12:01:24Z fairhead $
3 !
4  SUBROUTINE addfi(pdt, leapf, forward,
5  s pucov, pvcov, pteta, pq , pps ,
6  s pdufi, pdvfi, pdhfi,pdqfi, pdpfi )
7 
8  USE infotrac, ONLY : nqtot
9  USE control_mod, ONLY : planet_type
10  IMPLICIT NONE
11 c
12 c=======================================================================
13 c
14 c Addition of the physical tendencies
15 c
16 c Interface :
17 c -----------
18 c
19 c Input :
20 c -------
21 c pdt time step of integration
22 c leapf logical
23 c forward logical
24 c pucov(ip1jmp1,llm) first component of the covariant velocity
25 c pvcov(ip1ip1jm,llm) second component of the covariant velocity
26 c pteta(ip1jmp1,llm) potential temperature
27 c pts(ip1jmp1,llm) surface temperature
28 c pdufi(ip1jmp1,llm) |
29 c pdvfi(ip1jm,llm) | respective
30 c pdhfi(ip1jmp1) | tendencies
31 c pdtsfi(ip1jmp1) |
32 c
33 c Output :
34 c --------
35 c pucov
36 c pvcov
37 c ph
38 c pts
39 c
40 c
41 c=======================================================================
42 c
43 c-----------------------------------------------------------------------
44 c
45 c 0. Declarations :
46 c ------------------
47 c
48 #include "dimensions.h"
49 #include "paramet.h"
50 #include "comconst.h"
51 #include "comgeom.h"
52 #include "serre.h"
53 c
54 c Arguments :
55 c -----------
56 c
57  REAL pdt
58 c
59  REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
60  REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1)
61 c
62  REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
63  REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
64 c
65  LOGICAL leapf,forward
66 c
67 c
68 c Local variables :
69 c -----------------
70 c
71  REAL xpn(iim),xps(iim),tpn,tps
72  INTEGER j,k,iq,ij
73  REAL qtestw, qtestt
74  parameter( qtestw = 1.0e-15 )
75  parameter( qtestt = 1.0e-40 )
76 
77  REAL ssum
78 c
79 c-----------------------------------------------------------------------
80 
81  DO k = 1,llm
82  DO j = 1,ip1jmp1
83  pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
84  ENDDO
85  ENDDO
86 
87  DO k = 1, llm
88  DO ij = 1, iim
89  xpn(ij) = aire( ij ) * pteta( ij ,k)
90  xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
91  ENDDO
92  tpn = ssum(iim,xpn,1)/ apoln
93  tps = ssum(iim,xps,1)/ apols
94 
95  DO ij = 1, iip1
96  pteta( ij ,k) = tpn
97  pteta(ij+ip1jm,k) = tps
98  ENDDO
99  ENDDO
100 c
101 
102  DO k = 1,llm
103  DO j = iip2,ip1jm
104  pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
105  ENDDO
106  ENDDO
107 
108  DO k = 1,llm
109  DO j = 1,ip1jm
110  pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
111  ENDDO
112  ENDDO
113 
114 c
115  DO j = 1,ip1jmp1
116  pps(j) = pps(j) + pdpfi(j) * pdt
117  ENDDO
118 
119  if (planet_type=="earth") then
120  ! earth case, special treatment for first 2 tracers (water)
121  DO iq = 1, 2
122  DO k = 1,llm
123  DO j = 1,ip1jmp1
124  pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
125  pq(j,k,iq)= amax1( pq(j,k,iq), qtestw )
126  ENDDO
127  ENDDO
128  ENDDO
129 
130  DO iq = 3, nqtot
131  DO k = 1,llm
132  DO j = 1,ip1jmp1
133  pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
134  pq(j,k,iq)= amax1( pq(j,k,iq), qtestt )
135  ENDDO
136  ENDDO
137  ENDDO
138  else
139  ! general case, treat all tracers equally)
140  DO iq = 1, nqtot
141  DO k = 1,llm
142  DO j = 1,ip1jmp1
143  pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
144  pq(j,k,iq)= amax1( pq(j,k,iq), qtestt )
145  ENDDO
146  ENDDO
147  ENDDO
148  endif ! of if (planet_type=="earth")
149 
150 
151  DO ij = 1, iim
152  xpn(ij) = aire( ij ) * pps( ij )
153  xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
154  ENDDO
155  tpn = ssum(iim,xpn,1)/apoln
156  tps = ssum(iim,xps,1)/apols
157 
158  DO ij = 1, iip1
159  pps( ij ) = tpn
160  pps( ij+ip1jm ) = tps
161  ENDDO
162 
163 
164  DO iq = 1, nqtot
165  DO k = 1, llm
166  DO ij = 1, iim
167  xpn(ij) = aire( ij ) * pq( ij ,k,iq)
168  xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
169  ENDDO
170  tpn = ssum(iim,xpn,1)/apoln
171  tps = ssum(iim,xps,1)/apols
172 
173  DO ij = 1, iip1
174  pq( ij ,k,iq) = tpn
175  pq(ij+ip1jm,k,iq) = tps
176  ENDDO
177  ENDDO
178  ENDDO
179 
180  RETURN
181  END