/[MITgcm]/MITgcm_contrib/jscott/igsm/src_chem/chempdadv.F
ViewVC logotype

Contents of /MITgcm_contrib/jscott/igsm/src_chem/chempdadv.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.1 - (show annotations) (download)
Thu Sep 17 17:40:32 2009 UTC (15 years, 10 months ago) by jscott
Branch: MAIN
CVS Tags: HEAD
chem module archive

1
2 #include "ctrparam.h"
3
4 ! ============================================================
5 !
6 ! PDADV.F: Subroutines of Modified Bott advection scheme
7 !
8 ! ------------------------------------------------------------
9 !
10 ! Author: Chien Wang
11 ! MIT Joint Program on Science and Policy
12 ! of Global Change
13 !
14 ! ----------------------------------------------------------
15 !
16 ! Revision History:
17 !
18 ! When Who What
19 ! ---- ---------- -------
20 ! 080200 Chien Wang repack based on CliChem3 & add cpp
21 !
22 ! ==========================================================
23
24 C **************************************
25 C **************************************
26 SUBROUTINE pdadv1(C,W4,W2,W1,N)
27 C **************************************
28 C **************************************
29 C
30 C ******************************************************************
31 C
32 C This is a subroutine for the first part of Bott's advection scheme.
33 C
34 C Andreas Bott 1989: A Positive Definite Advection scheme obtained
35 C by Nonlinear Renormalization of the advective fluxes
36 C Mon. Wea. Rev. 117 1006-15
37 C
38 C Fourth Order: with coefficients from Mon. Wea. Rev. 117 2633-36
39 C
40 C Input: C=U*DT/DX[N+1] Output: W4[3:N1,5],W2[2;3;n1;n,3] and
41 C W1[1;2;n;n+1,2]
42 C On the Staggered Grid: C(i')----Q(i)----C(i'+1)
43 C
44 C ******************************************************************
45
46 PARAMETER ( C0=1.0/1920.0,C1=1.0/384.00,C2=1.0/384.0
47 & , C3=1.0/768.00,C4=1.0/3840.0,EP=1.0E-15 )
48 c parameter (cc0=1.,cc1=1./16.,cc2=1./48.)
49 parameter (cc0=-1./24.,cc1=1./16.,cc2=1./48.)
50 c parameter (cc0=-1./24.,cc1=1./16.,cc2=1./16.)
51
52 DIMENSION C(N+1),W4(N,5),W2(N,3),W1(4,2)
53
54 ! -----------------------------------------------------------
55
56 #if ( defined CPL_CHEM )
57
58 n1=n-1
59 n2=n-2
60 n3=n-3
61
62 do 1 i=1,n
63 do 2 j=1,5
64 w4(i,j)=0.0
65 2 continue
66 do 3 j=1,3
67 w2(i,j)=0.0
68 3 continue
69 1 continue
70
71 C
72 C GET THE COEFFICIENTS DEPENDENT ON C ONLY
73 C
74 w1(1,1)=abs(c(1))
75 w1(1,2)=0.0
76 w1(2,1)=abs(c(2))
77 w1(2,2)=2.0*w1(2,1)*(1.-w1(2,1))
78 w1(3,1)=abs(c(n))
79 w1(3,2)=2.0*w1(3,1)*(1.-w1(3,1))
80 w1(4,1)=abs(c(n+1))
81 w1(4,2)=0.0
82
83 rr1=abs(c(2))
84 rr2=1.-(rr1+rr1)
85 r1=rr2**2
86 r2=r1*rr2
87 w2(2,1)=rr1*cc0
88 w2(2,2)=(1.-r1)*cc1
89 w2(2,3)=(1.-r2)*cc2
90
91 rr1=abs(c(3))
92 rr2=1.-(rr1+rr1)
93 r1=rr2**2
94 r2=r1*rr2
95 w2(3,1)=rr1*cc0
96 w2(3,2)=(1.-r1)*cc1
97 w2(3,3)=(1.-r2)*cc2
98
99 rr1=abs(c(4))
100 rr2=1.-(rr1+rr1)
101 r1=rr2**2
102 r2=r1*rr2
103 w2(4,1)=rr1*cc0
104 w2(4,2)=(1.-r1)*cc1
105 w2(4,3)=(1.-r2)*cc2
106
107 rr1=abs(c(n2))
108 rr2=1.-(rr1+rr1)
109 r1=rr2**2
110 r2=r1*rr2
111 w2(n2,1)=rr1*cc0
112 w2(n2,2)=(1.-r1)*cc1
113 w2(n2,3)=(1.-r2)*cc2
114
115 rr1=abs(c(n1))
116 rr2=1.-(rr1+rr1)
117 r1=rr2**2
118 r2=r1*rr2
119 w2(n1,1)=rr1*cc0
120 w2(n1,2)=(1.-r1)*cc1
121 w2(n1,3)=(1.-r2)*cc2
122
123 rr1=abs(c(n))
124 rr2=1.-(rr1+rr1)
125 r1=rr2**2
126 r2=r1*rr2
127 w2(n,1)=rr1*cc0
128 w2(n,2)=(1.-r1)*cc1
129 w2(n,3)=(1.-r2)*cc2
130
131 DO 100 I = 3 ,N1
132
133 rr1 = ABS( C(I) )
134 rr2 = 1.0 - (rr1+rr1)
135 R1 = Rr2*Rr2
136 R2 = R1*Rr2
137 R3 = R2*Rr2
138 R4 = R3*Rr2
139
140 W4(I,1) = rr1 *C0
141 W4(I,2) = (1.0-R1)*C1
142 W4(I,3) = (1.0-R2)*C2
143 W4(I,4) = (1.0-R3)*C3
144 W4(I,5) = (1.0-R4)*C4
145
146 100 CONTINUE
147 C
148
149 #endif
150
151 return
152 end
153
154
155 C **************************************
156 C **************************************
157 SUBROUTINE pdadv2(C,Q,W4,W2,W1,ww,ww2,N,NOOS)
158 C **************************************
159 C **************************************
160 C
161 C *************************************************************
162 C
163 C This is a subroutine for the second part of Bott's advection
164 C scheme.
165 C
166 C Andreas Bott 1989: A Positive Definite Advection scheme obtained
167 C by Nonlinear Renormalization of the advective fluxes
168 C Mon. Wea. Rev. 117 1006-15
169 C
170 C Fourth Order: with coefficients from Mon. Wea. Rev. 117 2633-36
171 C
172 C Input: C=U*DT/DX[N+1] & Q[N] Output: Q[2 N-1]
173 C On the Staggered Grid: C(i')----Q(i)----C(i'+1)
174 C
175 C NOSS = 1: Perform non-oscillatory option
176 C
177 PARAMETER ( C0=1.0/1920.0,C1=1.0/384.00,C2=1.0/384.0
178 & , C3=1.0/768.00,C4=1.0/3840.0,EP=1.0E-15 )
179 c parameter ( cc0=1.,cc1=1./16.,cc2=1./24.)
180 parameter ( cc0=-1./24.,cc1=1./16.,cc2=1./24.)
181 c parameter ( cc0=-1./24.,cc1=1./16.,cc2=1./16.)
182
183 DIMENSION C(N+1),Q(N),W4(n,5),w2(n,3),w1(4,2),
184 & ww(n+1,5),ww2(n+1,5)
185 C
186
187 ! --------------------------------------------------------
188
189 #if ( defined CPL_CHEM )
190
191 N1 = N-1
192 N2 = N-2
193 N3 = N-3
194
195 do 1 i=1,(n+1)*5
196 ww (i,1)=0.0
197 ww2(i,1)=0.0
198 1 continue
199
200 C
201 C FOR ANY POSITIVE-DEFINITE Q ADVECTION
202 C
203 C 1. First order scheme for i=2 and n:
204
205 a0=q(1)
206 a1=q(2)-q(1)
207 ww(1,1)=a0
208 ww(1,2)=a0*w1(1,1)
209 ww(2,3)=a0*w1(2,1)+a1*w1(2,2)
210
211 a0=q(n)
212 a1=q(n)-q(n1)
213 ww(n,1)=a0
214 ww(n,2)=a0*w1(3,1)-a1*w1(3,2)
215 ww(n+1,3)=a0*w1(4,1)
216
217 C 2. Second order scheme for i=2,3,n1,n:
218
219 ww2(1,1)=ww(1,1)
220 ww2(1,2)=ww(1,2)
221 ww2(2,3)=ww(2,3)
222
223 a0=q(3)-26.*q(2)+q(1)
224 a1=q(3)-q(1)
225 a2=q(3)-2.*q(2)+q(1)
226 ww2(2,1)=cc0*a0+cc2*a2
227 ww2(2,2)=a0*w2(2,1)-a1*w2(2,2)+a2*w2(2,3)
228 ww2(3,3)=a0*w2(3,1)+a1*w2(3,2)+a2*w2(3,3)
229
230 a0=q(4)-26.*q(3)+q(2)
231 a1=q(4)-q(2)
232 a2=q(4)-2.*q(3)+q(2)
233 ww2(3,1)=cc0*a0+cc2*a2
234 ww2(3,2)=a0*w2(3,1)-a1*w2(3,2)+a2*w2(3,3)
235 ww2(4,3)=a0*w2(4,1)+a1*w2(4,2)+a2*w2(4,3)
236
237 a0=q(n1)-26.*q(n2)+q(n3)
238 a1=q(n1)-q(n3)
239 a2=q(n1)-2.0*q(n2)+q(n3)
240 ww2(n2,1)=cc0*a0+cc2*a2
241 ww2(n2,2)=a0*w2(n2,1)-a1*w2(n2,2)+a2*w2(n2,3)
242 ww2(n1,3)=a0*w2(n1,1)+a1*w2(n1,2)+a2*w2(n1,3)
243
244 a0=q(n)-26.*q(n1)+q(n2)
245 a1=q(n)-q(n2)
246 a2=q(n)-2.*q(n1)+q(n2)
247 ww2(n1,1)=cc0*a0+cc2*a2
248 ww2(n1,2)=a0*w2(n1,1)-a1*w2(n1,2)+a2*w2(n1,3)
249 ww2(n,3) =a0*w2( n,1)+a1*w2( n,2)+a2*w2( n,3)
250
251 ww2(n,1) =ww(n,1)
252 ww2(n,2) =ww(n,2)
253 ww2(n+1,3)=ww(n+1,3)
254
255 C 3. Fourth order scheme for i=3,n1:
256
257 ww(2,1)=ww2(2,1)
258 ww(2,2)=ww2(2,2)
259 ww(3,3)=ww2(3,3)
260
261 ww(n1,1)=ww2(n1,1)
262 ww(n1,2)=ww2(n1,2)
263 ww(n, 3)=ww2(n, 3)
264
265 DO 200 I = 3 ,N2
266 QL2 = Q(I-2)
267 QL1 = Q(I-1)
268 Q00 = Q(I)
269 QR1 = Q(I+1)
270 QR2 = Q(I+2)
271 QP1 = QR1+QL1
272 QP2 = QR2+QL2
273 QM1 = QR1-QL1
274 QM2 = QR2-QL2
275 C COEFFICIENTS: AREA PRESERVING FLUX FORM
276 A0 = 9.0*QP2 - 116.0*QP1 + 2134.0*Q00
277 A1 =-5.0*QM2 + 34.0*QM1
278 A2 = -QP2 + 12.0*QP1 - 22.0*Q00
279 A3 = QM2 - 2.0*QM1
280 A4 = QP2 - 4.0*QP1 + 6.0*Q00
281 C INTEGRALS: FOR THE USE OF IN/OUT FLUX OF THE GRID
282 ww(I,1) = C0*(A0+10.0*A2+A4)
283 c ww(I,1) = Q00
284 ww(I,2) = A0*W4(I,1)-A1*W4(I,2)+A2*W4(I,3)
285 & - A3*W4(I,4)+A4*W4(I,5)
286 ww(I+1,3) = A0*W4(I+1,1)+A1*W4(I+1,2)+A2*W4(I+1,3)
287 & +A3*W4(I+1,4)+A4*W4(I+1,5)
288 200 CONTINUE
289 C
290 C RESTRICT THE INTEGRALS TO PRESERVE THE SIGN
291 C
292 I = 1
293 IF( C(I).GT.0.0 ) THEN
294 ww(I,2) = 0.0
295 ELSE IF( C(I).LT.0.0 ) THEN
296 ww(I,2) = max( 0.0 , ww(I,2) )
297 ENDIF
298 DO 210 I = 2 ,N
299 IF( C(I).GT.0.0 ) THEN
300 ww(I,2) = 0.0
301 ww(I,3) = max( 0.0 , ww(I,3) )
302 ww2(i,2)= 0.0
303 ww2(i,3)= max( 0.0, ww2(i,3))
304 ELSE IF( C(I).LT.0.0 ) THEN
305 ww(I,2) = max( 0.0 , ww(I,2) )
306 ww(I,3) = 0.0
307 ww2(i,2)= max( 0.0, ww2(i,2) )
308 ww2(i,3)= 0.0
309 ENDIF
310 210 CONTINUE
311 I = N+1
312 IF( C(I).GT.0.0 ) THEN
313 ww(I,3) = max( 0.0 , ww(I,3) )
314 ELSE IF( C(I).LT.0.0 ) THEN
315 ww(I,3) = 0.0
316 ENDIF
317 DO 220 I = 1 ,N
318 ww(I,1) = max( ww(I,2)+ww(I+1,3)+EP , ww(I,1) )
319 ww2(i,1) = max(ww2(i,2)+ww2(i+1,3)+ep,ww2(i,1))
320 220 CONTINUE
321 C
322 C GET THE WEIGHTING FACTOR
323 C
324 DO 230 I = 1 ,N
325 ww(I,1) = Q(I) / ww(I,1)
326 ww2(i,1) = q(i) /ww2(i,1)
327 230 CONTINUE
328 C <= ww(I,2)
329 C GET THE IN/OUT FLUX OF THE GRID I --- I+1/2
330 C ww(I,3) =>
331 DO 250 I = 1 ,N+1
332 if(i.ne.n+1) ww(I,2) = ww(I,2)*ww(I,1)
333 if(i.ne.1) ww(I,3) = ww(I,3)*ww(I-1,1)
334 if(i.ne.n+1) ww2(i,2) = ww2(i,2)*ww2(i,1)
335 if(i.ne.1) ww2(i,3) = ww2(i,3)*ww2(i-1,1)
336 250 CONTINUE
337 C
338 IF( NOOS.NE.1 ) THEN
339 C COMPUTE THE TOTAL ADVECTION TENDENCY
340
341 c DO 300 I = 2 ,N1
342 q(2) =ww2(3,2)-ww2(3,3)-ww2(2,2) +ww2(2,3)
343 q(n1)=ww2(n,2)-ww2(n,3)-ww2(n1,2)+ww2(n1,3)
344 DO 300 I = 3 ,N2
345 c q(i) = ww(i+1,2)-ww(i+1,3)-ww(i,2)+ww(i,3) !tendency
346 q(i) = ww(i+1,2)-ww(i+1,3)-ww(i,2)+ww(i,3)+q(i) !value
347 300 CONTINUE
348 C
349 ELSE
350 C
351 C NON-OSCILLATORY OPTION: FCT LIMITER
352 C P.K.Smolarkiewicz & W.W.Grabowski, 1990: The multidimensional
353 C positive definite advection transport algorithm: Nonoscillatory
354 C option, J. Comput. Phys., 86, 355-375
355 C
356 C GET THE DONOR-CELL FLUXES (Low-order)
357
358 DO 400 I = 2 ,N
359 IF( C(I).GT.0.0 ) THEN
360 ww(I,1) = Q(I-1)
361 ELSE
362 ww(I,1) =-Q(I)
363 ENDIF
364 400 CONTINUE
365
366 c ww(1,1)=max(-q(1)*c(1),0.0)
367 ww(1,1)=abs(q(1)*c(1))
368 if(c(1).gt.0.0)then
369 ww(1,4)=0.0
370 ww(1,5)=ww(1,1)
371 else
372 ww(1,4)=ww(1,1)
373 ww(1,5)=0.0
374 endif
375
376 DO 405 I = 2 ,N
377 ww(I,1) = ww(I,1) * C(I)
378 ww(I,4) = 0.0
379 ww(I,5) = 0.0
380 405 CONTINUE
381
382 c ww(n+1,1)=max(q(n)*c(n+1),0.0)
383 ww(n+1,1)=abs(q(n)*c(n+1))
384 if(c(n+1).gt.0.0)then
385 ww(n+1,4)=0.0
386 ww(n+1,5)=ww(n+1,1)
387 else
388 ww(n+1,4)=ww(n+1,1)
389 ww(n+1,5)=0.0
390 endif
391
392 DO 410 I = 2 ,N
393 IF( C(I).GT.0.0 ) THEN
394 ww(I,5)= ww(I,1)
395 ELSE
396 ww(I,4) = ww(I,1)
397 ENDIF
398 410 CONTINUE
399
400 DO 415 I = 1 ,N
401 ww(I,1) = ww(I+1,4) - ww(I+1,5) - ww(I,4) + ww(I,5)
402 415 CONTINUE
403
404 DO 420 I = 1 ,N
405 ww(I,1) = ww(I,1) + Q(I)
406 c ww(I,1) = ww(I,1)
407 420 CONTINUE
408
409 C GET THE A-FLUX = F(High-order)-F(Low-order)
410 DO 430 I = 1 ,N
411 ww(I,4) = ww(I,2) - ww(I,4)
412 ww(I,5) = ww(I,3) - ww(I,5)
413 430 CONTINUE
414 DO 435 I = 1 ,N
415 ww(I,2) = max( 0.0,ww(I,4) ) - min(0.0, ww(I,5) )
416 ww(I,3) = max( 0.0,ww(I,5) ) - min(0.0, ww(I,4) )
417 435 CONTINUE
418
419 ww(1,4)=min(ww(1,1),ww(2,1),q(1),q(2))
420 ww(1,5)=max(ww(1,1),ww(2,1),q(1),q(2))
421 DO 440 I = 2 ,N1
422 J = I-1
423 K = I+1
424 ww(I,4) = min(ww(J,1),ww(I,1),ww(K,1),Q(J),Q(I),Q(K))
425 ww(I,5) = max(ww(J,1),ww(I,1),ww(K,1),Q(J),Q(I),Q(K))
426 440 CONTINUE
427 ww(n,4)=min(ww(n1,1),ww(n,1),q(n1),q(n))
428 ww(n,5)=max(ww(n1,1),ww(n,1),q(n1),q(n))
429
430 DO 450 I = 1 ,N
431 ww(I,4) =(ww(I,1)-ww(I,4)) / (ww(I,2)+ww(I+1,3)+EP)
432 ww(I,5) =(ww(I,5)-ww(I,1)) / (ww(I,3)+ww(I+1,2)+EP)
433 Q(I) = ww(I,01)
434 450 CONTINUE
435
436 DO 460 I = 2 ,N
437 ww(I,1) = min( 1.0,ww(I-1,5),ww(I,4) )
438 460 CONTINUE
439 DO 465 I = 2 ,N
440 ww(I,2) = ww(I,2) * ww(I,1)
441 465 CONTINUE
442 DO 470 I = 2 ,N
443 ww(I,1) = min( 1.0,ww(I-1,4),ww(I,5) )
444 470 CONTINUE
445 DO 475 I = 2 ,N
446 ww(I,3) = ww(I,3) * ww(I,1)
447 475 CONTINUE
448 C COMPUTE THE HIGH-ORDER ADVECTION TENDENCY
449 DO 500 I = 2 ,N1
450 ww(I,1) = ww(I+1,2)-ww(I+1,3)-ww(I,2)+ww(I,3)
451 500 CONTINUE
452 C
453 C COMPUTE THE TOTAL ADVECTION TENDENCY
454 C
455 DO 600 I = 2 ,N1
456 c q(i) = ww(i,1) !tendency
457 q(i) = ww(i,1)+q(i) !value
458 600 CONTINUE
459
460 ENDIF
461
462 #endif
463
464 RETURN
465 END
466

  ViewVC Help
Powered by ViewVC 1.1.22