/[MITgcm]/MITgcm/pkg/generic_advdiff/gad_advection.F
ViewVC logotype

Annotation of /MITgcm/pkg/generic_advdiff/gad_advection.F

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


Revision 1.37 - (hide annotations) (download)
Sat Oct 22 19:59:45 2005 UTC (18 years, 7 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint57w_post
Changes since 1.36: +19 -5 lines
add DST-2 & 1rst Order upwind scheme.

1 jmc 1.37 C $Header: /u/gcmpack/MITgcm/pkg/generic_advdiff/gad_advection.F,v 1.36 2005/10/10 05:53:49 mlosch Exp $
2 adcroft 1.2 C $Name: $
3 adcroft 1.4
4 adcroft 1.1 #include "GAD_OPTIONS.h"
5 jmc 1.30 #undef MULTIDIM_OLD_VERSION
6 adcroft 1.1
7 edhill 1.19 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
8 adcroft 1.4 CBOP
9     C !ROUTINE: GAD_ADVECTION
10    
11     C !INTERFACE: ==========================================================
12 jmc 1.17 SUBROUTINE GAD_ADVECTION(
13 jmc 1.23 I implicitAdvection, advectionScheme, vertAdvecScheme,
14     I tracerIdentity,
15 edhill 1.21 I uVel, vVel, wVel, tracer,
16     O gTracer,
17     I bi,bj, myTime,myIter,myThid)
18 adcroft 1.4
19     C !DESCRIPTION:
20     C Calculates the tendancy of a tracer due to advection.
21     C It uses the multi-dimensional method given in \ref{sect:multiDimAdvection}
22     C and can only be used for the non-linear advection schemes such as the
23     C direct-space-time method and flux-limiters.
24     C
25     C The algorithm is as follows:
26     C \begin{itemize}
27     C \item{$\theta^{(n+1/3)} = \theta^{(n)}
28 adcroft 1.5 C - \Delta t \partial_x (u\theta^{(n)}) + \theta^{(n)} \partial_x u$}
29 adcroft 1.4 C \item{$\theta^{(n+2/3)} = \theta^{(n+1/3)}
30 adcroft 1.5 C - \Delta t \partial_y (v\theta^{(n+1/3)}) + \theta^{(n)} \partial_y v$}
31 adcroft 1.4 C \item{$\theta^{(n+3/3)} = \theta^{(n+2/3)}
32 adcroft 1.5 C - \Delta t \partial_r (w\theta^{(n+2/3)}) + \theta^{(n)} \partial_r w$}
33 adcroft 1.4 C \item{$G_\theta = ( \theta^{(n+3/3)} - \theta^{(n)} )/\Delta t$}
34     C \end{itemize}
35     C
36     C The tendancy (output) is over-written by this routine.
37    
38     C !USES: ===============================================================
39 adcroft 1.1 IMPLICIT NONE
40     #include "SIZE.h"
41     #include "EEPARAMS.h"
42     #include "PARAMS.h"
43     #include "GRID.h"
44     #include "GAD.h"
45 heimbach 1.6 #ifdef ALLOW_AUTODIFF_TAMC
46     # include "tamc.h"
47     # include "tamc_keys.h"
48 heimbach 1.27 # ifdef ALLOW_PTRACERS
49     # include "PTRACERS_SIZE.h"
50     # endif
51 heimbach 1.6 #endif
52 dimitri 1.24 #ifdef ALLOW_EXCH2
53     #include "W2_EXCH2_TOPOLOGY.h"
54     #include "W2_EXCH2_PARAMS.h"
55     #endif /* ALLOW_EXCH2 */
56 adcroft 1.1
57 adcroft 1.4 C !INPUT PARAMETERS: ===================================================
58 edhill 1.21 C implicitAdvection :: implicit vertical advection (later on)
59 jmc 1.23 C advectionScheme :: advection scheme to use (Horizontal plane)
60     C vertAdvecScheme :: advection scheme to use (vertical direction)
61 edhill 1.21 C tracerIdentity :: tracer identifier (required only for OBCS)
62     C uVel :: velocity, zonal component
63     C vVel :: velocity, meridional component
64     C wVel :: velocity, vertical component
65     C tracer :: tracer field
66     C bi,bj :: tile indices
67     C myTime :: current time
68     C myIter :: iteration number
69     C myThid :: thread number
70 jmc 1.17 LOGICAL implicitAdvection
71 jmc 1.23 INTEGER advectionScheme, vertAdvecScheme
72 adcroft 1.1 INTEGER tracerIdentity
73 jmc 1.17 _RL uVel (1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
74     _RL vVel (1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
75     _RL wVel (1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
76     _RL tracer(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
77     INTEGER bi,bj
78 adcroft 1.1 _RL myTime
79     INTEGER myIter
80     INTEGER myThid
81    
82 adcroft 1.4 C !OUTPUT PARAMETERS: ==================================================
83 edhill 1.21 C gTracer :: tendancy array
84 adcroft 1.9 _RL gTracer(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
85 adcroft 1.4
86     C !LOCAL VARIABLES: ====================================================
87 edhill 1.21 C maskUp :: 2-D array for mask at W points
88 jmc 1.29 C maskLocW :: 2-D array for mask at West points
89     C maskLocS :: 2-D array for mask at South points
90 edhill 1.21 C iMin,iMax, :: loop range for called routines
91     C jMin,jMax :: loop range for called routines
92 jmc 1.30 C [iMin,iMax]Upd :: loop range to update tracer field
93     C [jMin,jMax]Upd :: loop range to update tracer field
94 edhill 1.21 C i,j,k :: loop indices
95     C kup :: index into 2 1/2D array, toggles between 1 and 2
96     C kdown :: index into 2 1/2D array, toggles between 2 and 1
97     C kp1 :: =k+1 for k<Nr, =Nr for k=Nr
98     C xA,yA :: areas of X and Y face of tracer cells
99     C uTrans,vTrans :: 2-D arrays of volume transports at U,V points
100     C rTrans :: 2-D arrays of volume transports at W points
101     C rTransKp1 :: vertical volume transport at interface k+1
102 jmc 1.30 C af :: 2-D array for horizontal advective flux
103 jmc 1.29 C afx :: 2-D array for horizontal advective flux, x direction
104     C afy :: 2-D array for horizontal advective flux, y direction
105 edhill 1.21 C fVerT :: 2 1/2D arrays for vertical advective flux
106     C localTij :: 2-D array, temporary local copy of tracer fld
107     C localTijk :: 3-D array, temporary local copy of tracer fld
108     C kp1Msk :: flag (0,1) for over-riding mask for W levels
109     C calc_fluxes_X :: logical to indicate to calculate fluxes in X dir
110     C calc_fluxes_Y :: logical to indicate to calculate fluxes in Y dir
111 jmc 1.30 C interiorOnly :: only update the interior of myTile, but not the edges
112     C overlapOnly :: only update the edges of myTile, but not the interior
113 edhill 1.21 C nipass :: number of passes in multi-dimensional method
114     C ipass :: number of the current pass being made
115 dimitri 1.24 C myTile :: variables used to determine which cube face
116     C nCFace :: owns a tile for cube grid runs using
117     C :: multi-dim advection.
118 jmc 1.30 C [N,S,E,W]_edge :: true if N,S,E,W edge of myTile is an Edge of the cube
119 adcroft 1.1 _RS maskUp (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
120 jmc 1.29 _RS maskLocW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
121     _RS maskLocS(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
122 adcroft 1.1 INTEGER iMin,iMax,jMin,jMax
123 jmc 1.30 INTEGER iMinUpd,iMaxUpd,jMinUpd,jMaxUpd
124 jmc 1.11 INTEGER i,j,k,kup,kDown
125 adcroft 1.1 _RS xA (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
126     _RS yA (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
127     _RL uTrans (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
128     _RL vTrans (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
129     _RL rTrans (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
130 jmc 1.11 _RL rTransKp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
131 jmc 1.30 _RL af (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
132 jmc 1.29 _RL afx (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
133     _RL afy (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
134 adcroft 1.1 _RL fVerT (1-OLx:sNx+OLx,1-OLy:sNy+OLy,2)
135     _RL localTij(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
136     _RL localTijk(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr)
137     _RL kp1Msk
138 jmc 1.29 LOGICAL calc_fluxes_X, calc_fluxes_Y, withSigns
139 jmc 1.30 LOGICAL interiorOnly, overlapOnly
140 adcroft 1.3 INTEGER nipass,ipass
141 dimitri 1.24 INTEGER myTile, nCFace
142 jmc 1.30 LOGICAL N_edge, S_edge, E_edge, W_edge
143 jmc 1.33 #ifdef ALLOW_DIAGNOSTICS
144     CHARACTER*8 diagName
145     CHARACTER*4 GAD_DIAG_SUFX, diagSufx
146     EXTERNAL GAD_DIAG_SUFX
147     #endif
148 adcroft 1.4 CEOP
149 adcroft 1.1
150 heimbach 1.6 #ifdef ALLOW_AUTODIFF_TAMC
151 heimbach 1.14 act0 = tracerIdentity - 1
152     max0 = maxpass
153 heimbach 1.6 act1 = bi - myBxLo(myThid)
154     max1 = myBxHi(myThid) - myBxLo(myThid) + 1
155     act2 = bj - myByLo(myThid)
156     max2 = myByHi(myThid) - myByLo(myThid) + 1
157     act3 = myThid - 1
158     max3 = nTx*nTy
159     act4 = ikey_dynamics - 1
160 heimbach 1.14 igadkey = (act0 + 1)
161     & + act1*max0
162     & + act2*max0*max1
163     & + act3*max0*max1*max2
164     & + act4*max0*max1*max2*max3
165 heimbach 1.15 if (tracerIdentity.GT.maxpass) then
166     print *, 'ph-pass gad_advection ', maxpass, tracerIdentity
167     STOP 'maxpass seems smaller than tracerIdentity'
168     endif
169 heimbach 1.6 #endif /* ALLOW_AUTODIFF_TAMC */
170    
171 jmc 1.33 #ifdef ALLOW_DIAGNOSTICS
172     C-- Set diagnostic suffix for the current tracer
173     IF ( useDiagnostics ) THEN
174     diagSufx = GAD_DIAG_SUFX( tracerIdentity, myThid )
175     ENDIF
176     #endif
177    
178 adcroft 1.1 C-- Set up work arrays with valid (i.e. not NaN) values
179     C These inital values do not alter the numerical results. They
180     C just ensure that all memory references are to valid floating
181     C point numbers. This prevents spurious hardware signals due to
182     C uninitialised but inert locations.
183     DO j=1-OLy,sNy+OLy
184     DO i=1-OLx,sNx+OLx
185     xA(i,j) = 0. _d 0
186     yA(i,j) = 0. _d 0
187     uTrans(i,j) = 0. _d 0
188     vTrans(i,j) = 0. _d 0
189     rTrans(i,j) = 0. _d 0
190     fVerT(i,j,1) = 0. _d 0
191     fVerT(i,j,2) = 0. _d 0
192 jmc 1.11 rTransKp1(i,j)= 0. _d 0
193 adcroft 1.1 ENDDO
194     ENDDO
195    
196 jmc 1.30 C-- Set tile-specific parameters for horizontal fluxes
197     IF (useCubedSphereExchange) THEN
198     nipass=3
199     #ifdef ALLOW_AUTODIFF_TAMC
200     IF ( nipass.GT.maxcube ) STOP 'maxcube needs to be = 3'
201     #endif
202     #ifdef ALLOW_EXCH2
203     myTile = W2_myTileList(bi)
204     nCFace = exch2_myFace(myTile)
205     N_edge = exch2_isNedge(myTile).EQ.1
206     S_edge = exch2_isSedge(myTile).EQ.1
207     E_edge = exch2_isEedge(myTile).EQ.1
208     W_edge = exch2_isWedge(myTile).EQ.1
209     #else
210     nCFace = bi
211     N_edge = .TRUE.
212     S_edge = .TRUE.
213     E_edge = .TRUE.
214     W_edge = .TRUE.
215     #endif
216     ELSE
217     nipass=2
218     N_edge = .FALSE.
219     S_edge = .FALSE.
220     E_edge = .FALSE.
221     W_edge = .FALSE.
222     ENDIF
223    
224 adcroft 1.1 iMin = 1-OLx
225     iMax = sNx+OLx
226     jMin = 1-OLy
227     jMax = sNy+OLy
228    
229     C-- Start of k loop for horizontal fluxes
230     DO k=1,Nr
231 heimbach 1.6 #ifdef ALLOW_AUTODIFF_TAMC
232 heimbach 1.14 kkey = (igadkey-1)*Nr + k
233     CADJ STORE tracer(:,:,k,bi,bj) =
234     CADJ & comlev1_bibj_k_gad, key=kkey, byte=isbyte
235 heimbach 1.6 #endif /* ALLOW_AUTODIFF_TAMC */
236 adcroft 1.1
237     C-- Get temporary terms used by tendency routines
238     CALL CALC_COMMON_FACTORS (
239     I bi,bj,iMin,iMax,jMin,jMax,k,
240     O xA,yA,uTrans,vTrans,rTrans,maskUp,
241     I myThid)
242    
243 jmc 1.11 #ifdef ALLOW_GMREDI
244     C-- Residual transp = Bolus transp + Eulerian transp
245 jmc 1.30 IF (useGMRedi)
246 jmc 1.11 & CALL GMREDI_CALC_UVFLOW(
247     & uTrans, vTrans, bi, bj, k, myThid)
248     #endif /* ALLOW_GMREDI */
249    
250 jmc 1.29 C-- Make local copy of tracer array and mask West & South
251 adcroft 1.1 DO j=1-OLy,sNy+OLy
252     DO i=1-OLx,sNx+OLx
253 jmc 1.30 localTij(i,j)=tracer(i,j,k,bi,bj)
254     maskLocW(i,j)=maskW(i,j,k,bi,bj)
255     maskLocS(i,j)=maskS(i,j,k,bi,bj)
256 adcroft 1.1 ENDDO
257     ENDDO
258    
259 heimbach 1.31 #ifndef ALLOW_AUTODIFF_TAMC
260 jmc 1.29 IF (useCubedSphereExchange) THEN
261     withSigns = .FALSE.
262     CALL FILL_CS_CORNER_UV_RS(
263     & withSigns, maskLocW,maskLocS, bi,bj, myThid )
264     ENDIF
265 heimbach 1.31 #endif
266 adcroft 1.3
267     C-- Multiple passes for different directions on different tiles
268 dimitri 1.24 C-- For cube need one pass for each of red, green and blue axes.
269 adcroft 1.3 DO ipass=1,nipass
270 heimbach 1.6 #ifdef ALLOW_AUTODIFF_TAMC
271 heimbach 1.14 passkey = ipass + (k-1) *maxcube
272     & + (igadkey-1)*maxcube*Nr
273 heimbach 1.6 IF (nipass .GT. maxpass) THEN
274 heimbach 1.14 STOP 'GAD_ADVECTION: nipass > maxcube. check tamc.h'
275 heimbach 1.6 ENDIF
276     #endif /* ALLOW_AUTODIFF_TAMC */
277 adcroft 1.3
278 jmc 1.30 interiorOnly = .FALSE.
279     overlapOnly = .FALSE.
280     IF (useCubedSphereExchange) THEN
281     #ifdef MULTIDIM_OLD_VERSION
282     C- CubedSphere : pass 3 times, with full update of local tracer field
283     IF (ipass.EQ.1) THEN
284     calc_fluxes_X = nCFace.EQ.1 .OR. nCFace.EQ.2
285     calc_fluxes_Y = nCFace.EQ.4 .OR. nCFace.EQ.5
286     ELSEIF (ipass.EQ.2) THEN
287     calc_fluxes_X = nCFace.EQ.3 .OR. nCFace.EQ.4
288     calc_fluxes_Y = nCFace.EQ.6 .OR. nCFace.EQ.1
289     #else /* MULTIDIM_OLD_VERSION */
290     C- CubedSphere : pass 3 times, with partial update of local tracer field
291     IF (ipass.EQ.1) THEN
292     overlapOnly = MOD(nCFace,3).EQ.0
293     interiorOnly = MOD(nCFace,3).NE.0
294     calc_fluxes_X = nCFace.EQ.6 .OR. nCFace.EQ.1 .OR. nCFace.EQ.2
295     calc_fluxes_Y = nCFace.EQ.3 .OR. nCFace.EQ.4 .OR. nCFace.EQ.5
296     ELSEIF (ipass.EQ.2) THEN
297     overlapOnly = MOD(nCFace,3).EQ.2
298     calc_fluxes_X = nCFace.EQ.2 .OR. nCFace.EQ.3 .OR. nCFace.EQ.4
299     calc_fluxes_Y = nCFace.EQ.5 .OR. nCFace.EQ.6 .OR. nCFace.EQ.1
300     #endif /* MULTIDIM_OLD_VERSION */
301     ELSE
302     calc_fluxes_X = nCFace.EQ.5 .OR. nCFace.EQ.6
303     calc_fluxes_Y = nCFace.EQ.2 .OR. nCFace.EQ.3
304 adcroft 1.3 ENDIF
305     ELSE
306 jmc 1.30 C- not CubedSphere
307     calc_fluxes_X = MOD(ipass,2).EQ.1
308     calc_fluxes_Y = .NOT.calc_fluxes_X
309 adcroft 1.3 ENDIF
310    
311 jmc 1.29 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
312 adcroft 1.3 C-- X direction
313     IF (calc_fluxes_X) THEN
314    
315 jmc 1.30 C- Do not compute fluxes if
316     C a) needed in overlap only
317     C and b) the overlap of myTile are not cube-face Edges
318     IF ( .NOT.overlapOnly .OR. N_edge .OR. S_edge ) THEN
319    
320 heimbach 1.31 #ifndef ALLOW_AUTODIFF_TAMC
321 jmc 1.30 C- Internal exchange for calculations in X
322     #ifdef MULTIDIM_OLD_VERSION
323     IF ( useCubedSphereExchange ) THEN
324     #else
325     IF ( useCubedSphereExchange .AND.
326     & ( overlapOnly .OR. ipass.EQ.1 ) ) THEN
327     #endif
328 jmc 1.29 CALL FILL_CS_CORNER_TR_RL( .TRUE., localTij, bi,bj, myThid )
329 jmc 1.30 ENDIF
330 heimbach 1.31 #endif
331 adcroft 1.3
332 jmc 1.30 C- Advective flux in X
333     DO j=1-Oly,sNy+Oly
334     DO i=1-Olx,sNx+Olx
335     af(i,j) = 0.
336     ENDDO
337     ENDDO
338 heimbach 1.6
339     #ifdef ALLOW_AUTODIFF_TAMC
340 adcroft 1.7 #ifndef DISABLE_MULTIDIM_ADVECTION
341 heimbach 1.14 CADJ STORE localTij(:,:) =
342     CADJ & comlev1_bibj_k_gad_pass, key=passkey, byte=isbyte
343 heimbach 1.6 #endif
344     #endif /* ALLOW_AUTODIFF_TAMC */
345    
346 jmc 1.37 IF ( advectionScheme.EQ.ENUM_UPWIND_1RST
347     & .OR. advectionScheme.EQ.ENUM_DST2 ) THEN
348     CALL GAD_DST2U1_ADV_X( bi,bj,k, advectionScheme,
349     I dTtracerLev(k),uTrans,uVel,localTij,
350     O af, myThid )
351     ELSEIF (advectionScheme.EQ.ENUM_FLUX_LIMIT) THEN
352 jmc 1.32 CALL GAD_FLUXLIMIT_ADV_X( bi,bj,k, dTtracerLev(k),
353 jmc 1.30 I uTrans, uVel, maskLocW, localTij,
354     O af, myThid )
355     ELSEIF (advectionScheme.EQ.ENUM_DST3 ) THEN
356 jmc 1.32 CALL GAD_DST3_ADV_X( bi,bj,k, dTtracerLev(k),
357 jmc 1.30 I uTrans, uVel, maskLocW, localTij,
358     O af, myThid )
359     ELSEIF (advectionScheme.EQ.ENUM_DST3_FLUX_LIMIT ) THEN
360 jmc 1.32 CALL GAD_DST3FL_ADV_X( bi,bj,k, dTtracerLev(k),
361 jmc 1.30 I uTrans, uVel, maskLocW, localTij,
362     O af, myThid )
363     ELSE
364     STOP 'GAD_ADVECTION: adv. scheme incompatibale with multi-dim'
365     ENDIF
366    
367     C- Advective flux in X : done
368     ENDIF
369    
370 heimbach 1.31 #ifndef ALLOW_AUTODIFF_TAMC
371 jmc 1.30 C- Internal exchange for next calculations in Y
372     IF ( overlapOnly .AND. ipass.EQ.1 ) THEN
373     CALL FILL_CS_CORNER_TR_RL(.FALSE., localTij, bi,bj, myThid )
374     ENDIF
375 heimbach 1.31 #endif
376 jmc 1.30
377     C- Update the local tracer field where needed:
378    
379     C update in overlap-Only
380     IF ( overlapOnly ) THEN
381     iMinUpd = 1-Olx+1
382     iMaxUpd = sNx+Olx-1
383     C- notes: these 2 lines below have no real effect (because recip_hFac=0
384     C in corner region) but safer to keep them.
385     IF ( W_edge ) iMinUpd = 1
386     IF ( E_edge ) iMaxUpd = sNx
387    
388     IF ( S_edge ) THEN
389     DO j=1-Oly,0
390     DO i=iMinUpd,iMaxUpd
391 jmc 1.32 localTij(i,j)=localTij(i,j)-dTtracerLev(k)*
392 jmc 1.30 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
393     & *recip_rA(i,j,bi,bj)
394     & *( af(i+1,j)-af(i,j)
395     & -tracer(i,j,k,bi,bj)*(uTrans(i+1,j)-uTrans(i,j))
396     & )
397     ENDDO
398     ENDDO
399     ENDIF
400     IF ( N_edge ) THEN
401     DO j=sNy+1,sNy+Oly
402     DO i=iMinUpd,iMaxUpd
403 jmc 1.32 localTij(i,j)=localTij(i,j)-dTtracerLev(k)*
404 jmc 1.30 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
405     & *recip_rA(i,j,bi,bj)
406     & *( af(i+1,j)-af(i,j)
407     & -tracer(i,j,k,bi,bj)*(uTrans(i+1,j)-uTrans(i,j))
408     & )
409     ENDDO
410     ENDDO
411     ENDIF
412 heimbach 1.6
413 jmc 1.30 ELSE
414     C do not only update the overlap
415     jMinUpd = 1-Oly
416     jMaxUpd = sNy+Oly
417     IF ( interiorOnly .AND. S_edge ) jMinUpd = 1
418     IF ( interiorOnly .AND. N_edge ) jMaxUpd = sNy
419     DO j=jMinUpd,jMaxUpd
420     DO i=1-Olx+1,sNx+Olx-1
421 jmc 1.32 localTij(i,j)=localTij(i,j)-dTtracerLev(k)*
422 jmc 1.30 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
423     & *recip_rA(i,j,bi,bj)
424     & *( af(i+1,j)-af(i,j)
425     & -tracer(i,j,k,bi,bj)*(uTrans(i+1,j)-uTrans(i,j))
426     & )
427     ENDDO
428     ENDDO
429     C- keep advective flux (for diagnostics)
430     DO j=1-Oly,sNy+Oly
431     DO i=1-Olx,sNx+Olx
432     afx(i,j) = af(i,j)
433     ENDDO
434     ENDDO
435 adcroft 1.1
436     #ifdef ALLOW_OBCS
437 jmc 1.30 C- Apply open boundary conditions
438     IF ( useOBCS ) THEN
439     IF (tracerIdentity.EQ.GAD_TEMPERATURE) THEN
440     CALL OBCS_APPLY_TLOC( bi, bj, k, localTij, myThid )
441     ELSEIF (tracerIdentity.EQ.GAD_SALINITY) THEN
442     CALL OBCS_APPLY_SLOC( bi, bj, k, localTij, myThid )
443 mlosch 1.36 #ifdef ALLOW_PTRACERS
444     ELSEIF (tracerIdentity.GE.GAD_TR1) THEN
445     CALL OBCS_APPLY_PTRACER( bi, bj, k,
446     & tracerIdentity-GAD_TR1+1, localTij, myThid )
447     #endif /* ALLOW_PTRACERS */
448 jmc 1.30 ENDIF
449     ENDIF
450 adcroft 1.1 #endif /* ALLOW_OBCS */
451    
452 jmc 1.30 C- end if/else update overlap-Only
453     ENDIF
454    
455 adcroft 1.3 C-- End of X direction
456     ENDIF
457    
458 jmc 1.29 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
459 adcroft 1.3 C-- Y direction
460     IF (calc_fluxes_Y) THEN
461    
462 jmc 1.30 C- Do not compute fluxes if
463     C a) needed in overlap only
464     C and b) the overlap of myTile are not cube-face edges
465     IF ( .NOT.overlapOnly .OR. E_edge .OR. W_edge ) THEN
466    
467 heimbach 1.31 #ifndef ALLOW_AUTODIFF_TAMC
468 jmc 1.30 C- Internal exchange for calculations in Y
469     #ifdef MULTIDIM_OLD_VERSION
470     IF ( useCubedSphereExchange ) THEN
471     #else
472     IF ( useCubedSphereExchange .AND.
473     & ( overlapOnly .OR. ipass.EQ.1 ) ) THEN
474     #endif
475 jmc 1.29 CALL FILL_CS_CORNER_TR_RL(.FALSE., localTij, bi,bj, myThid )
476 jmc 1.30 ENDIF
477 heimbach 1.31 #endif
478 adcroft 1.3
479 jmc 1.30 C- Advective flux in Y
480     DO j=1-Oly,sNy+Oly
481     DO i=1-Olx,sNx+Olx
482     af(i,j) = 0.
483     ENDDO
484     ENDDO
485 heimbach 1.6
486     #ifdef ALLOW_AUTODIFF_TAMC
487 adcroft 1.7 #ifndef DISABLE_MULTIDIM_ADVECTION
488 heimbach 1.14 CADJ STORE localTij(:,:) =
489     CADJ & comlev1_bibj_k_gad_pass, key=passkey, byte=isbyte
490 heimbach 1.6 #endif
491     #endif /* ALLOW_AUTODIFF_TAMC */
492    
493 jmc 1.37 IF ( advectionScheme.EQ.ENUM_UPWIND_1RST
494     & .OR. advectionScheme.EQ.ENUM_DST2 ) THEN
495     CALL GAD_DST2U1_ADV_Y( bi,bj,k, advectionScheme,
496     I dTtracerLev(k),vTrans,vVel,localTij,
497     O af, myThid )
498     ELSEIF (advectionScheme.EQ.ENUM_FLUX_LIMIT) THEN
499 jmc 1.32 CALL GAD_FLUXLIMIT_ADV_Y( bi,bj,k, dTtracerLev(k),
500 jmc 1.30 I vTrans, vVel, maskLocS, localTij,
501     O af, myThid )
502     ELSEIF (advectionScheme.EQ.ENUM_DST3 ) THEN
503 jmc 1.32 CALL GAD_DST3_ADV_Y( bi,bj,k, dTtracerLev(k),
504 jmc 1.30 I vTrans, vVel, maskLocS, localTij,
505     O af, myThid )
506     ELSEIF (advectionScheme.EQ.ENUM_DST3_FLUX_LIMIT ) THEN
507 jmc 1.32 CALL GAD_DST3FL_ADV_Y( bi,bj,k, dTtracerLev(k),
508 jmc 1.30 I vTrans, vVel, maskLocS, localTij,
509     O af, myThid )
510     ELSE
511     STOP 'GAD_ADVECTION: adv. scheme incompatibale with mutli-dim'
512     ENDIF
513    
514     C- Advective flux in Y : done
515     ENDIF
516    
517 heimbach 1.31 #ifndef ALLOW_AUTODIFF_TAMC
518 jmc 1.30 C- Internal exchange for next calculations in X
519     IF ( overlapOnly .AND. ipass.EQ.1 ) THEN
520     CALL FILL_CS_CORNER_TR_RL( .TRUE., localTij, bi,bj, myThid )
521     ENDIF
522 heimbach 1.31 #endif
523 jmc 1.30
524     C- Update the local tracer field where needed:
525    
526     C update in overlap-Only
527     IF ( overlapOnly ) THEN
528     jMinUpd = 1-Oly+1
529     jMaxUpd = sNy+Oly-1
530     C- notes: these 2 lines below have no real effect (because recip_hFac=0
531     C in corner region) but safer to keep them.
532     IF ( S_edge ) jMinUpd = 1
533     IF ( N_edge ) jMaxUpd = sNy
534    
535     IF ( W_edge ) THEN
536     DO j=jMinUpd,jMaxUpd
537     DO i=1-Olx,0
538 jmc 1.32 localTij(i,j)=localTij(i,j)-dTtracerLev(k)*
539 jmc 1.30 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
540     & *recip_rA(i,j,bi,bj)
541     & *( af(i,j+1)-af(i,j)
542     & -tracer(i,j,k,bi,bj)*(vTrans(i,j+1)-vTrans(i,j))
543     & )
544     ENDDO
545     ENDDO
546     ENDIF
547     IF ( E_edge ) THEN
548     DO j=jMinUpd,jMaxUpd
549     DO i=sNx+1,sNx+Olx
550 jmc 1.32 localTij(i,j)=localTij(i,j)-dTtracerLev(k)*
551 jmc 1.30 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
552     & *recip_rA(i,j,bi,bj)
553     & *( af(i,j+1)-af(i,j)
554     & -tracer(i,j,k,bi,bj)*(vTrans(i,j+1)-vTrans(i,j))
555     & )
556     ENDDO
557     ENDDO
558     ENDIF
559 heimbach 1.6
560 jmc 1.30 ELSE
561     C do not only update the overlap
562     iMinUpd = 1-Olx
563     iMaxUpd = sNx+Olx
564     IF ( interiorOnly .AND. W_edge ) iMinUpd = 1
565     IF ( interiorOnly .AND. E_edge ) iMaxUpd = sNx
566     DO j=1-Oly+1,sNy+Oly-1
567     DO i=iMinUpd,iMaxUpd
568 jmc 1.32 localTij(i,j)=localTij(i,j)-dTtracerLev(k)*
569 jmc 1.30 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
570     & *recip_rA(i,j,bi,bj)
571     & *( af(i,j+1)-af(i,j)
572     & -tracer(i,j,k,bi,bj)*(vTrans(i,j+1)-vTrans(i,j))
573     & )
574     ENDDO
575     ENDDO
576     C- keep advective flux (for diagnostics)
577     DO j=1-Oly,sNy+Oly
578     DO i=1-Olx,sNx+Olx
579     afy(i,j) = af(i,j)
580     ENDDO
581     ENDDO
582 adcroft 1.3
583 adcroft 1.1 #ifdef ALLOW_OBCS
584 jmc 1.30 C- Apply open boundary conditions
585     IF (useOBCS) THEN
586     IF (tracerIdentity.EQ.GAD_TEMPERATURE) THEN
587     CALL OBCS_APPLY_TLOC( bi, bj, k, localTij, myThid )
588     ELSEIF (tracerIdentity.EQ.GAD_SALINITY) THEN
589     CALL OBCS_APPLY_SLOC( bi, bj, k, localTij, myThid )
590 mlosch 1.36 #ifdef ALLOW_PTRACERS
591     ELSEIF (tracerIdentity.GE.GAD_TR1) THEN
592     CALL OBCS_APPLY_PTRACER( bi, bj, k,
593     & tracerIdentity-GAD_TR1+1, localTij, myThid )
594     #endif /* ALLOW_PTRACERS */
595 jmc 1.30 ENDIF
596     ENDIF
597 adcroft 1.1 #endif /* ALLOW_OBCS */
598 adcroft 1.3
599 jmc 1.30 C end if/else update overlap-Only
600     ENDIF
601    
602 adcroft 1.3 C-- End of Y direction
603     ENDIF
604    
605 jmc 1.18 C-- End of ipass loop
606 adcroft 1.1 ENDDO
607    
608 jmc 1.18 IF ( implicitAdvection ) THEN
609     C- explicit advection is done ; store tendency in gTracer:
610     DO j=1-Oly,sNy+Oly
611     DO i=1-Olx,sNx+Olx
612     gTracer(i,j,k,bi,bj)=
613 jmc 1.32 & (localTij(i,j)-tracer(i,j,k,bi,bj))/dTtracerLev(k)
614 jmc 1.18 ENDDO
615     ENDDO
616     ELSE
617     C- horizontal advection done; store intermediate result in 3D array:
618     DO j=1-Oly,sNy+Oly
619     DO i=1-Olx,sNx+Olx
620     localTijk(i,j,k)=localTij(i,j)
621     ENDDO
622     ENDDO
623     ENDIF
624 adcroft 1.1
625 jmc 1.33 #ifdef ALLOW_DIAGNOSTICS
626     IF ( useDiagnostics ) THEN
627     diagName = 'ADVx'//diagSufx
628 jmc 1.34 CALL DIAGNOSTICS_FILL(afx,diagName, k,1, 2,bi,bj, myThid)
629 jmc 1.33 diagName = 'ADVy'//diagSufx
630 jmc 1.34 CALL DIAGNOSTICS_FILL(afy,diagName, k,1, 2,bi,bj, myThid)
631 jmc 1.33 ENDIF
632     #endif
633    
634 jmc 1.29 #ifdef ALLOW_DEBUG
635     IF ( debugLevel .GE. debLevB
636 jmc 1.30 & .AND. tracerIdentity.EQ.GAD_TEMPERATURE
637     & .AND. k.LE.3 .AND. myIter.EQ.1+nIter0
638 jmc 1.29 & .AND. nPx.EQ.1 .AND. nPy.EQ.1
639     & .AND. useCubedSphereExchange ) THEN
640     CALL DEBUG_CS_CORNER_UV( ' afx,afy from GAD_ADVECTION',
641     & afx,afy, k, standardMessageUnit,bi,bj,myThid )
642     ENDIF
643     #endif /* ALLOW_DEBUG */
644    
645 adcroft 1.1 C-- End of K loop for horizontal fluxes
646     ENDDO
647    
648 jmc 1.29 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
649    
650 jmc 1.18 IF ( .NOT.implicitAdvection ) THEN
651 adcroft 1.1 C-- Start of k loop for vertical flux
652 jmc 1.18 DO k=Nr,1,-1
653 heimbach 1.6 #ifdef ALLOW_AUTODIFF_TAMC
654 heimbach 1.16 kkey = (igadkey-1)*Nr + k
655 heimbach 1.6 #endif /* ALLOW_AUTODIFF_TAMC */
656 adcroft 1.1 C-- kup Cycles through 1,2 to point to w-layer above
657     C-- kDown Cycles through 2,1 to point to w-layer below
658 jmc 1.18 kup = 1+MOD(k+1,2)
659     kDown= 1+MOD(k,2)
660     c kp1=min(Nr,k+1)
661     kp1Msk=1.
662     if (k.EQ.Nr) kp1Msk=0.
663 heimbach 1.6
664 jmc 1.11 C-- Compute Vertical transport
665 jmc 1.22 #ifdef ALLOW_AIM
666     C- a hack to prevent Water-Vapor vert.transport into the stratospheric level Nr
667     IF ( k.EQ.1 .OR.
668     & (useAIM .AND. tracerIdentity.EQ.GAD_SALINITY .AND. k.EQ.Nr)
669     & ) THEN
670     #else
671     IF ( k.EQ.1 ) THEN
672     #endif
673 jmc 1.11
674     C- Surface interface :
675 jmc 1.18 DO j=1-Oly,sNy+Oly
676     DO i=1-Olx,sNx+Olx
677 jmc 1.22 rTransKp1(i,j) = kp1Msk*rTrans(i,j)
678 jmc 1.18 rTrans(i,j) = 0.
679     fVerT(i,j,kUp) = 0.
680     ENDDO
681     ENDDO
682 jmc 1.11
683 jmc 1.18 ELSE
684     C- Interior interface :
685 jmc 1.11
686 jmc 1.18 DO j=1-Oly,sNy+Oly
687     DO i=1-Olx,sNx+Olx
688     rTransKp1(i,j) = kp1Msk*rTrans(i,j)
689     rTrans(i,j) = wVel(i,j,k,bi,bj)*rA(i,j,bi,bj)
690     & *maskC(i,j,k-1,bi,bj)
691 jmc 1.29 fVerT(i,j,kUp) = 0.
692 jmc 1.18 ENDDO
693     ENDDO
694 jmc 1.11
695     #ifdef ALLOW_GMREDI
696     C-- Residual transp = Bolus transp + Eulerian transp
697 jmc 1.18 IF (useGMRedi)
698 jmc 1.11 & CALL GMREDI_CALC_WFLOW(
699     & rTrans, bi, bj, k, myThid)
700     #endif /* ALLOW_GMREDI */
701    
702 heimbach 1.16 #ifdef ALLOW_AUTODIFF_TAMC
703     CADJ STORE localTijk(:,:,k)
704     CADJ & = comlev1_bibj_k_gad, key=kkey, byte=isbyte
705     CADJ STORE rTrans(:,:)
706     CADJ & = comlev1_bibj_k_gad, key=kkey, byte=isbyte
707     #endif /* ALLOW_AUTODIFF_TAMC */
708    
709 adcroft 1.1 C- Compute vertical advective flux in the interior:
710 jmc 1.37 IF ( advectionScheme.EQ.ENUM_UPWIND_1RST
711     & .OR. advectionScheme.EQ.ENUM_DST2 ) THEN
712     CALL GAD_DST2U1_ADV_R( bi,bj,k, advectionScheme,
713     I dTtracerLev(k),rTrans,wVel,localTijk,
714     O fVerT(1-Olx,1-Oly,kUp), myThid )
715     ELSEIF (advectionScheme.EQ.ENUM_FLUX_LIMIT) THEN
716 jmc 1.32 CALL GAD_FLUXLIMIT_ADV_R( bi,bj,k, dTtracerLev(k),
717 jmc 1.29 I rTrans, wVel, localTijk,
718     O fVerT(1-Olx,1-Oly,kUp), myThid )
719 jmc 1.23 ELSEIF (vertAdvecScheme.EQ.ENUM_DST3 ) THEN
720 jmc 1.32 CALL GAD_DST3_ADV_R( bi,bj,k, dTtracerLev(k),
721 jmc 1.29 I rTrans, wVel, localTijk,
722     O fVerT(1-Olx,1-Oly,kUp), myThid )
723 jmc 1.23 ELSEIF (vertAdvecScheme.EQ.ENUM_DST3_FLUX_LIMIT ) THEN
724 jmc 1.32 CALL GAD_DST3FL_ADV_R( bi,bj,k, dTtracerLev(k),
725 jmc 1.29 I rTrans, wVel, localTijk,
726     O fVerT(1-Olx,1-Oly,kUp), myThid )
727 jmc 1.18 ELSE
728     STOP 'GAD_ADVECTION: adv. scheme incompatibale with mutli-dim'
729     ENDIF
730 jmc 1.11
731     C- end Surface/Interior if bloc
732 jmc 1.18 ENDIF
733 heimbach 1.16
734     #ifdef ALLOW_AUTODIFF_TAMC
735     CADJ STORE rTrans(:,:)
736     CADJ & = comlev1_bibj_k_gad, key=kkey, byte=isbyte
737     CADJ STORE rTranskp1(:,:)
738     CADJ & = comlev1_bibj_k_gad, key=kkey, byte=isbyte
739     #endif /* ALLOW_AUTODIFF_TAMC */
740 adcroft 1.1
741 jmc 1.18 C-- Divergence of vertical fluxes
742     DO j=1-Oly,sNy+Oly
743     DO i=1-Olx,sNx+Olx
744 jmc 1.32 localTij(i,j)=localTijk(i,j,k)-dTtracerLev(k)*
745 jmc 1.18 & _recip_hFacC(i,j,k,bi,bj)*recip_drF(k)
746     & *recip_rA(i,j,bi,bj)
747 jmc 1.35 & *( fVerT(i,j,kDown)-fVerT(i,j,kUp)
748     & -tracer(i,j,k,bi,bj)*(rTransKp1(i,j)-rTrans(i,j))
749     & )*rkSign
750 jmc 1.18 gTracer(i,j,k,bi,bj)=
751 jmc 1.32 & (localTij(i,j)-tracer(i,j,k,bi,bj))/dTtracerLev(k)
752 jmc 1.18 ENDDO
753     ENDDO
754 adcroft 1.1
755 jmc 1.33 #ifdef ALLOW_DIAGNOSTICS
756     IF ( useDiagnostics ) THEN
757     diagName = 'ADVr'//diagSufx
758     CALL DIAGNOSTICS_FILL( fVerT(1-Olx,1-Oly,kUp),
759 jmc 1.34 & diagName, k,1, 2,bi,bj, myThid)
760 jmc 1.33 ENDIF
761     #endif
762    
763 adcroft 1.1 C-- End of K loop for vertical flux
764 jmc 1.18 ENDDO
765     C-- end of if not.implicitAdvection block
766     ENDIF
767 adcroft 1.1
768     RETURN
769     END

  ViewVC Help
Powered by ViewVC 1.1.22