forked from altMITgcm/MITgcm
-
Notifications
You must be signed in to change notification settings - Fork 0
/
shap_filt_uv_s2g.F
139 lines (117 loc) · 4.06 KB
/
shap_filt_uv_s2g.F
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
C $Header: /u/gcmpack/MITgcm/pkg/shap_filt/Attic/shap_filt_uv_s2g.F,v 1.2 2001/05/29 14:01:40 adcroft Exp $
C $Name: $
#include "SHAP_FILT_OPTIONS.h"
SUBROUTINE SHAP_FILT_UV_S2G(
U uFld, vFld,
I myTime, myThid )
C /==========================================================\
C | S/R SHAP_FILT_UV_S2 |
C | Applies Shapiro filter to U,V field over one XY slice |
C | of one tile at a time. |
C \==========================================================/
IMPLICIT NONE
C == Global variables ===
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "GRID.h"
#include "SHAP_FILT.h"
#include "SHAP_FILT_UV.h"
C == Routine arguments
_RL uFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
_RL vFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
_RL myTime
INTEGER myThid
#ifdef ALLOW_SHAP_FILT
C == Local variables ==
INTEGER bi,bj,K,I,J,N
_RS hFacZ(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
_RS r_hFacZ(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
_RL hDiv(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
_RL vort3(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
_RL tmpGrdU(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
_RL tmpGrdV(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
IF (nShapUV.gt.0 .AND. Shap_uvtau.GT.0.) THEN
DO bj=myByLo(myThid),myByHi(myThid)
DO bi=myBxLo(myThid),myBxHi(myThid)
DO K=1,Nr
DO J=1,sNy
DO I=1,sNx+1
tmpFldU(i,j,k,bi,bj)=uFld(i,j,k,bi,bj)
& *_maskW(i,j,k,bi,bj)
ENDDO
ENDDO
DO J=1,sNy+1
DO I=1,sNx
tmpFldV(i,j,k,bi,bj)=vFld(i,j,k,bi,bj)
& *_maskS(i,j,k,bi,bj)
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C [d_xx+d_yy]^n tmpFld
DO N=1,nShapUV
CALL EXCH_UV_XYZ_RL(tmpFldU,tmpFldV,.TRUE.,myThid)
DO bj=myByLo(myThid),myByHi(myThid)
DO bi=myBxLo(myThid),myBxHi(myThid)
DO K=1,Nr
C [d_xx+d_yy] tmpFld
CALL MOM_CALC_HFACZ(bi,bj,k,hFacZ,r_hFacZ,myThid)
CALL MOM_VI_CALC_HDIV(bi,bj,k,
I tmpFldU(1-OLx,1-OLy,k,bi,bj),
I tmpFldV(1-OLx,1-OLy,k,bi,bj),
& hDiv,myThid)
CALL MOM_VI_CALC_RELVORT3(bi,bj,k,
I tmpFldU(1-OLx,1-OLy,k,bi,bj),
I tmpFldV(1-OLx,1-OLy,k,bi,bj),
& hFacZ,vort3,myThid)
CALL MOM_VI_DEL2UV(
I bi,bj,k,hDiv,vort3,hFacZ,
O tmpGrdU,tmpGrdV,
& myThid)
IF (Shap_uvLength.EQ.0.) THEN
DO J=1,sNy+1
DO I=1,sNx+1
tmpFldU(i,j,k,bi,bj) = -0.125
& *rAw(i,j,bi,bj)*tmpGrdU(i,j)*_maskW(i,j,k,bi,bj)
tmpFldV(i,j,k,bi,bj) = -0.125
& *rAs(i,j,bi,bj)*tmpGrdV(i,j)*_maskS(i,j,k,bi,bj)
ENDDO
ENDDO
ELSE
DO J=1,sNy+1
DO I=1,sNx+1
tmpFldU(i,j,k,bi,bj) = -0.125
& *Shap_uvLength*Shap_uvLength
& *tmpGrdU(i,j)*_maskW(i,j,k,bi,bj)
tmpFldV(i,j,k,bi,bj) = -0.125
& *Shap_uvLength*Shap_uvLength
& *tmpGrdV(i,j)*_maskS(i,j,k,bi,bj)
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
C F <- [1 - (d_xx+d_yy)^n *deltat/tau].F
DO bj=myByLo(myThid),myByHi(myThid)
DO bi=myBxLo(myThid),myBxHi(myThid)
DO K=1,Nr
DO J=1,sNy+1
DO I=1,sNx+1
uFld(i,j,k,bi,bj)=uFld(i,j,k,bi,bj)
& -tmpFldU(i,j,k,bi,bj)*deltaTmom/Shap_uvtau
vFld(i,j,k,bi,bj)=vFld(i,j,k,bi,bj)
& -tmpFldV(i,j,k,bi,bj)*deltaTmom/Shap_uvtau
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
CALL EXCH_UV_XYZ_RL(uFld,vFld,.TRUE.,myThid)
ENDIF
#endif /* ALLOW_SHAP_FILT */
RETURN
END