pkg/generic_advdiff/gad_os7mp_adv_x.F

C $Header: /u/gcmpack/MITgcm/pkg/generic_advdiff/gad_os7mp_adv_x.F,v 1.7 2007/10/05 10:50:47 mlosch Exp $
C $Name:  $

#include "GAD_OPTIONS.h"

      SUBROUTINE GAD_OS7MP_ADV_X(
     I           bi,bj,k, calcCFL, deltaTloc,
     I           uTrans, uFld,
     I           maskLocW, Q,
     O           uT,
     I           myThid )
C     /==========================================================\
C     | SUBROUTINE GAD_OS7MP_ADV_X                               |
C     | o Compute Zonal advective Flux of tracer Q using         |
C     |   7th Order DST Sceheme with monotone preserving limiter |
C     |==========================================================|
      IMPLICIT NONE

C     == GLobal variables ==
#include "SIZE.h"
#include "GRID.h"
#include "GAD.h"

C     == Routine arguments ==
      INTEGER bi,bj,k
      LOGICAL calcCFL
      _RL deltaTloc
      _RL uTrans(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
      _RL uFld  (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
      _RS maskLocW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
      _RL Q     (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
      _RL uT    (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
      INTEGER myThid

C     == Local variables ==
      INTEGER i,j
      _RL cfl,Psi
      _RL uLoc,Fac,DelIp,DelI,Phi,Eps,rp1h,rp1h_cfl
      _RL Qippp,Qipp,Qip,Qi,Qim,Qimm,Qimmm
      _RL MskIpp,MskIp,MskI,MskIm,MskImm,MskImmm
      _RL d2,d2p1,d2m1,A,B,C,D
      _RL dp1h,dm1h,qMD,qUL,qLC,PhiMD,PhiLC,PhiMin,PhiMax
      _RL DelM,DelP,DelMM,DelPP,DelMMM,DelPPP
      _RL Del2MM,Del2M,Del2,Del2P,Del2PP
      _RL Del3MM,Del3M,Del3P,Del3PP
      _RL Del4M,Del4,Del4P
      _RL Del5M,Del5P
      _RL Del6

      Eps = 1. _d -20

      DO j=1-Oly,sNy+Oly
       uT(1-Olx,j)=0. _d 0
       uT(2-Olx,j)=0. _d 0
       uT(3-Olx,j)=0. _d 0
       uT(4-Olx,j)=0. _d 0
       uT(sNx+Olx-2,j)=0. _d 0
       uT(sNx+Olx-1,j)=0. _d 0
       uT(sNx+Olx,j)=0. _d 0
      ENDDO
      DO j=1-Oly,sNy+Oly
       DO i=1-Olx+4,sNx+Olx-3

        uLoc = uFld(i,j)
        cfl = uLoc
        IF ( calcCFL ) cfl = abs(uLoc*deltaTloc*recip_dxC(i,j,bi,bj))

        IF (uTrans(i,j).gt.0.) THEN
         Qippp = Q(i+2,j)
         Qipp  = Q(i+1,j)
         Qip   = Q(i,j)
         Qi    = Q(i-1,j)
         Qim   = Q(i-2,j)
         Qimm  = Q(i-3,j)
         Qimmm = Q(i-4,j)

         MskIpp  = maskLocW(i+2,j)
         MskIp   = maskLocW(i+1,j)
         MskI    = maskLocW(i,j)
         MskIm   = maskLocW(i-1,j)
         MskImm  = maskLocW(i-2,j)
         MskImmm = maskLocW(i-3,j)
        ELSEIF (uTrans(i,j).lt.0.) THEN
         Qippp = Q(i-3,j)
         Qipp  = Q(i-2,j)
         Qip   = Q(i-1,j)
         Qi    = Q(i,j)
         Qim   = Q(i+1,j)
         Qimm  = Q(i+2,j)
         Qimmm = Q(i+3,j)

         MskIpp  = maskLocW(i-2,j)
         MskIp   = maskLocW(i-1,j)
         MskI    = maskLocW(i,j)
         MskIm   = maskLocW(i+1,j)
         MskImm  = maskLocW(i+2,j)
         MskImmm = maskLocW(i+3,j)
        ELSE
         Qippp = 0. _d 0
         Qipp  = 0. _d 0
         Qip   = 0. _d 0
         Qi    = 0. _d 0
         Qim   = 0. _d 0
         Qimm  = 0. _d 0
         Qimmm = 0. _d 0

         MskIpp  = 0. _d 0
         MskIp   = 0. _d 0
         MskI    = 0. _d 0
         MskIm   = 0. _d 0
         MskImm  = 0. _d 0
         MskImmm = 0. _d 0
        ENDIF

        IF (uTrans(i,j).ne.0.) THEN
C        2nd order correction [i i-1]
         Fac = 1.
         DelP = (Qip-Qi)*MskI
         Phi = Fac * DelP
C        3rd order correction [i i-1 i-2]
         Fac = Fac * ( cfl + 1. )/3.
         DelM = (Qi-Qim)*MskIm
         Del2 = DelP - DelM
         Phi = Phi - Fac * Del2
C        4th order correction [i+1 i i-1 i-2]
         Fac = Fac * ( cfl - 2. )/4.
         DelPP = (Qipp-Qip)*MskIp*MskI
         Del2P = DelPP - DelP
         Del3P = Del2P - Del2
         Phi = Phi + Fac * Del3p
C        5th order correction [i+1 i i-1 i-2 i-3]
         Fac = Fac * ( cfl - 3. )/5.
         DelMM = (Qim-Qimm)*MskImm*MskIm
         Del2M = DelM - DelMM
         Del3M = Del2 - Del2M
         Del4 = Del3P - Del3M
         Phi = Phi + Fac * Del4
C        6th order correction [i+2 i+1 i i-1 i-2 i-3]
         Fac = Fac * ( cfl + 2. )/6.
         DelPPP = (Qippp-Qipp)*MskIpp*MskIp*MskI
         Del2PP = DelPP - DelP
         Del3PP = Del2PP - Del2P
         Del4P = Del3PP - Del3P
         Del5P = Del4P - Del4
         Phi = Phi + Fac * Del5P
C        7th order correction [i+2 i+1 i i-1 i-2 i-3 i-4]
         Fac = Fac * ( cfl + 2. )/7.
         DelMMM = (Qimm-Qimmm)*MskImmm*MskImm*MskIm
         Del2MM = DelMM - DelMMM
         Del3MM = Del2M - Del2MM
         Del4M = Del3M - Del3MM
         Del5M = Del4 - Del4M
         Del6 = Del5P - Del5M
         Phi = Phi - Fac * Del6

         DelIp = ( Qip - Qi ) * MskI
         Phi = sign(1. _d 0,Phi)*sign(1. _d 0,DelIp)
     &        *abs(Phi+Eps)/abs(DelIp+Eps)

         DelI = ( Qi - Qim ) * MskIm
         rp1h =sign(1. _d 0,DelI)*sign(1. _d 0,DelIp)
     &        *abs(DelI+Eps)/abs(DelIp+Eps)
         rp1h_cfl = rp1h/(cfl+Eps)

C        TVD limiter
!        Phi = max(0. _d 0, min( 2./(1-cfl), Phi, 2.*rp1h_cfl ) )

C        MP limiter
         d2   = Del2 !( ( Qip + Qim ) - 2.*Qi  ) * MskI * MskIm
         d2p1 = Del2P !( ( Qipp + Qi ) - 2.*Qip ) * MskIp * MskI
         d2m1 = Del2M !( ( Qi + Qimm ) - 2.*Qim ) * MskIm * MskImm
         A = 4.*d2 - d2p1
         B = 4.*d2p1 - d2
         C = d2
         D = d2p1
         dp1h = max(min(A,B,C,D),0. _d 0)+min(max(A,B,C,D),0. _d 0)
         A = 4.*d2m1 - d2
         B = 4.*d2 - d2m1
         C = d2m1
         D = d2
         dm1h = max(min(A,B,C,D),0. _d 0)+min(max(A,B,C,D),0. _d 0)
        !qMD = 0.5*( ( Qi + Qip ) - dp1h )
         qMD = 0.5*( ( 2.*Qi + DelIp ) - dp1h )
         qUL = Qi + (1.-cfl)/(cfl+Eps)*DelI
         qLC = Qi + 0.5*( 1.+dm1h/(DelI+Eps) )*(qUL-Qi)
         PhiMD = 2./(1.-cfl)*(qMD-Qi+Eps)/(DelIp+Eps)
         PhiLC = 2.*rp1h_cfl*(qLC-Qi+Eps)/(qUL-Qi+Eps)
         PhiMin = max(min(0. _d 0,PhiMD),
     &        min(0. _d 0,2.*rp1h_cfl,PhiLC))
         PhiMax = min(max(2. _d 0/(1.-cfl),PhiMD),
     &        max(0. _d 0,2.*rp1h_cfl,PhiLC))
         Phi = max(PhiMin,min(Phi,PhiMax))

         Psi = Phi * 0.5 * (1. - cfl)
         uT(i,j) = uTrans(i,j)*( Qi + Psi*DelIp )
        ELSE
         uT(i,j) = 0.
        ENDIF

       ENDDO
      ENDDO

      RETURN
      END
1	mlosch	1.8	C $Header: /u/gcmpack/MITgcm/pkg/generic_advdiff/gad_os7mp_adv_x.F,v 1.7 2007/10/05 10:50:47 mlosch Exp $
2	mlosch	1.2	C $Name: $
3	adcroft	1.1
4			#include "GAD_OPTIONS.h"
5
6			SUBROUTINE GAD_OS7MP_ADV_X(
7	jmc	1.3	I bi,bj,k, calcCFL, deltaTloc,
8	adcroft	1.1	I uTrans, uFld,
9			I maskLocW, Q,
10			O uT,
11			I myThid )
12			C /==========================================================\
13			C \| SUBROUTINE GAD_OS7MP_ADV_X \|
14			C \| o Compute Zonal advective Flux of tracer Q using \|
15			C \| 7th Order DST Sceheme with monotone preserving limiter \|
16			C \|==========================================================\|
17			IMPLICIT NONE
18
19			C == GLobal variables ==
20			#include "SIZE.h"
21			#include "GRID.h"
22			#include "GAD.h"
23
24			C == Routine arguments ==
25			INTEGER bi,bj,k
26	jmc	1.3	LOGICAL calcCFL
27	adcroft	1.1	_RL deltaTloc
28			_RL uTrans(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
29			_RL uFld (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
30			_RS maskLocW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
31			_RL Q (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
32			_RL uT (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
33			INTEGER myThid
34
35			C == Local variables ==
36			INTEGER i,j
37			_RL cfl,Psi
38	adcroft	1.5	_RL uLoc,Fac,DelIp,DelI,Phi,Eps,rp1h,rp1h_cfl
39	adcroft	1.1	_RL Qippp,Qipp,Qip,Qi,Qim,Qimm,Qimmm
40			_RL MskIpp,MskIp,MskI,MskIm,MskImm,MskImmm
41			_RL d2,d2p1,d2m1,A,B,C,D
42			_RL dp1h,dm1h,qMD,qUL,qLC,PhiMD,PhiLC,PhiMin,PhiMax
43	adcroft	1.5	_RL DelM,DelP,DelMM,DelPP,DelMMM,DelPPP
44			_RL Del2MM,Del2M,Del2,Del2P,Del2PP
45			_RL Del3MM,Del3M,Del3P,Del3PP
46			_RL Del4M,Del4,Del4P
47			_RL Del5M,Del5P
48			_RL Del6
49	adcroft	1.1
50			Eps = 1. _d -20
51
52			DO j=1-Oly,sNy+Oly
53			uT(1-Olx,j)=0. _d 0
54			uT(2-Olx,j)=0. _d 0
55			uT(3-Olx,j)=0. _d 0
56			uT(4-Olx,j)=0. _d 0
57			uT(sNx+Olx-2,j)=0. _d 0
58			uT(sNx+Olx-1,j)=0. _d 0
59			uT(sNx+Olx,j)=0. _d 0
60	mlosch	1.8	ENDDO
61			DO j=1-Oly,sNy+Oly
62	adcroft	1.1	DO i=1-Olx+4,sNx+Olx-3
63
64			uLoc = uFld(i,j)
65	jmc	1.3	cfl = uLoc
66			IF ( calcCFL ) cfl = abs(uLocdeltaTlocrecip_dxC(i,j,bi,bj))
67	adcroft	1.1
68	adcroft	1.4	IF (uTrans(i,j).gt.0.) THEN
69	adcroft	1.1	Qippp = Q(i+2,j)
70			Qipp = Q(i+1,j)
71			Qip = Q(i,j)
72			Qi = Q(i-1,j)
73			Qim = Q(i-2,j)
74			Qimm = Q(i-3,j)
75			Qimmm = Q(i-4,j)
76
77			MskIpp = maskLocW(i+2,j)
78			MskIp = maskLocW(i+1,j)
79			MskI = maskLocW(i,j)
80			MskIm = maskLocW(i-1,j)
81			MskImm = maskLocW(i-2,j)
82			MskImmm = maskLocW(i-3,j)
83	adcroft	1.4	ELSEIF (uTrans(i,j).lt.0.) THEN
84	adcroft	1.1	Qippp = Q(i-3,j)
85			Qipp = Q(i-2,j)
86			Qip = Q(i-1,j)
87			Qi = Q(i,j)
88			Qim = Q(i+1,j)
89			Qimm = Q(i+2,j)
90			Qimmm = Q(i+3,j)
91
92			MskIpp = maskLocW(i-2,j)
93			MskIp = maskLocW(i-1,j)
94			MskI = maskLocW(i,j)
95			MskIm = maskLocW(i+1,j)
96			MskImm = maskLocW(i+2,j)
97			MskImmm = maskLocW(i+3,j)
98	mlosch	1.7	ELSE
99			Qippp = 0. _d 0
100			Qipp = 0. _d 0
101			Qip = 0. _d 0
102			Qi = 0. _d 0
103			Qim = 0. _d 0
104			Qimm = 0. _d 0
105			Qimmm = 0. _d 0
106
107			MskIpp = 0. _d 0
108			MskIp = 0. _d 0
109			MskI = 0. _d 0
110			MskIm = 0. _d 0
111			MskImm = 0. _d 0
112			MskImmm = 0. _d 0
113	adcroft	1.1	ENDIF
114
115	adcroft	1.4	IF (uTrans(i,j).ne.0.) THEN
116	adcroft	1.1	C 2nd order correction [i i-1]
117			Fac = 1.
118	adcroft	1.5	DelP = (Qip-Qi)*MskI
119			Phi = Fac * DelP
120	adcroft	1.1	C 3rd order correction [i i-1 i-2]
121			Fac = Fac * ( cfl + 1. )/3.
122	adcroft	1.5	DelM = (Qi-Qim)*MskIm
123			Del2 = DelP - DelM
124			Phi = Phi - Fac * Del2
125	adcroft	1.1	C 4th order correction [i+1 i i-1 i-2]
126			Fac = Fac * ( cfl - 2. )/4.
127	adcroft	1.5	DelPP = (Qipp-Qip)MskIpMskI
128			Del2P = DelPP - DelP
129			Del3P = Del2P - Del2
130			Phi = Phi + Fac * Del3p
131	adcroft	1.1	C 5th order correction [i+1 i i-1 i-2 i-3]
132			Fac = Fac * ( cfl - 3. )/5.
133	adcroft	1.5	DelMM = (Qim-Qimm)MskImmMskIm
134			Del2M = DelM - DelMM
135			Del3M = Del2 - Del2M
136			Del4 = Del3P - Del3M
137			Phi = Phi + Fac * Del4
138	adcroft	1.1	C 6th order correction [i+2 i+1 i i-1 i-2 i-3]
139			Fac = Fac * ( cfl + 2. )/6.
140	adcroft	1.5	DelPPP = (Qippp-Qipp)MskIppMskIp*MskI
141			Del2PP = DelPP - DelP
142			Del3PP = Del2PP - Del2P
143			Del4P = Del3PP - Del3P
144			Del5P = Del4P - Del4
145			Phi = Phi + Fac * Del5P
146	adcroft	1.1	C 7th order correction [i+2 i+1 i i-1 i-2 i-3 i-4]
147			Fac = Fac * ( cfl + 2. )/7.
148	adcroft	1.5	DelMMM = (Qimm-Qimmm)MskImmmMskImm*MskIm
149			Del2MM = DelMM - DelMMM
150			Del3MM = Del2M - Del2MM
151			Del4M = Del3M - Del3MM
152			Del5M = Del4 - Del4M
153			Del6 = Del5P - Del5M
154			Phi = Phi - Fac * Del6
155	adcroft	1.1
156			DelIp = ( Qip - Qi ) * MskI
157	mlosch	1.2	Phi = sign(1. _d 0,Phi)*sign(1. _d 0,DelIp)
158			& *abs(Phi+Eps)/abs(DelIp+Eps)
159	adcroft	1.1
160			DelI = ( Qi - Qim ) * MskIm
161	mlosch	1.2	rp1h =sign(1. _d 0,DelI)*sign(1. _d 0,DelIp)
162			& *abs(DelI+Eps)/abs(DelIp+Eps)
163	adcroft	1.4	rp1h_cfl = rp1h/(cfl+Eps)
164	adcroft	1.1
165			C TVD limiter
166	adcroft	1.4	! Phi = max(0. _d 0, min( 2./(1-cfl), Phi, 2.*rp1h_cfl ) )
167	adcroft	1.1
168			C MP limiter
169	adcroft	1.5	d2 = Del2 !( ( Qip + Qim ) - 2.Qi ) MskI * MskIm
170			d2p1 = Del2P !( ( Qipp + Qi ) - 2.Qip ) MskIp * MskI
171			d2m1 = Del2M !( ( Qi + Qimm ) - 2.Qim ) MskIm * MskImm
172	adcroft	1.1	A = 4.*d2 - d2p1
173			B = 4.*d2p1 - d2
174			C = d2
175	jmc	1.6	D = d2p1
176	mlosch	1.2	dp1h = max(min(A,B,C,D),0. _d 0)+min(max(A,B,C,D),0. _d 0)
177	adcroft	1.1	A = 4.*d2m1 - d2
178			B = 4.*d2 - d2m1
179			C = d2m1
180	jmc	1.6	D = d2
181	mlosch	1.2	dm1h = max(min(A,B,C,D),0. _d 0)+min(max(A,B,C,D),0. _d 0)
182	adcroft	1.5	!qMD = 0.5*( ( Qi + Qip ) - dp1h )
183			qMD = 0.5( ( 2.Qi + DelIp ) - dp1h )
184			qUL = Qi + (1.-cfl)/(cfl+Eps)*DelI
185			qLC = Qi + 0.5( 1.+dm1h/(DelI+Eps) )(qUL-Qi)
186			PhiMD = 2./(1.-cfl)*(qMD-Qi+Eps)/(DelIp+Eps)
187	adcroft	1.4	PhiLC = 2.rp1h_cfl(qLC-Qi+Eps)/(qUL-Qi+Eps)
188	mlosch	1.2	PhiMin = max(min(0. _d 0,PhiMD),
189	adcroft	1.4	& min(0. _d 0,2.*rp1h_cfl,PhiLC))
190	mlosch	1.2	PhiMax = min(max(2. _d 0/(1.-cfl),PhiMD),
191	adcroft	1.4	& max(0. _d 0,2.*rp1h_cfl,PhiLC))
192	adcroft	1.1	Phi = max(PhiMin,min(Phi,PhiMax))
193
194			Psi = Phi * 0.5 * (1. - cfl)
195			uT(i,j) = uTrans(i,j)( Qi + PsiDelIp )
196			ELSE
197			uT(i,j) = 0.
198			ENDIF
199
200			ENDDO
201			ENDDO
202
203			RETURN
204			END