pkg/mom_common/mom_calc_relvort3.F

7c7b0b4a46 Alis*0001 #include "MOM_COMMON_OPTIONS.h"
6bffe74a45 Jean*0002 #undef CALC_CS_CORNER_EXTENDED
aea29c8517 Alis*0003
f2da9de9fe Jean*0004       SUBROUTINE MOM_CALC_RELVORT3(
aea29c8517 Alis*0005      I        bi,bj,k,
                0006      I        uFld, vFld, hFacZ,
                0007      O        vort3,
220a9e88b5 Jean*0008      I        myThid )
aea29c8517 Alis*0009       IMPLICIT NONE
f2da9de9fe Jean*0010 C     *==========================================================*
                0011 C     | S/R MOM_CALC_RELVORT3
                0012 C     *==========================================================*
                0013 C     *==========================================================*
aea29c8517 Alis*0014
                0015 C     == Global variables ==
                0016 #include "SIZE.h"
                0017 #include "EEPARAMS.h"
                0018 #include "PARAMS.h"
                0019 #include "GRID.h"
4749c74143 Alis*0020 #ifdef ALLOW_EXCH2
f9f661930b Jean*0021 #include "W2_EXCH2_SIZE.h"
404487e0d3 Andr*0022 #include "W2_EXCH2_TOPOLOGY.h"
4749c74143 Alis*0023 #endif /* ALLOW_EXCH2 */
aea29c8517 Alis*0024 C     == Routine arguments ==
                0025 C     myThid - Instance number for this innvocation of CALC_MOM_RHS
                0026       INTEGER bi,bj,k
                0027       _RL uFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0028       _RL vFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0029       _RS hFacZ(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0030       _RL vort3(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0031       INTEGER myThid
                0032
                0033 C     == Local variables ==
                0034       INTEGER i,j
404487e0d3 Andr*0035       LOGICAL northWestCorner, northEastCorner,
                0036      &        southWestCorner, southEastCorner
f7fdcad707 Jean*0037       INTEGER myFace
4749c74143 Alis*0038 #ifdef ALLOW_EXCH2
404487e0d3 Andr*0039       INTEGER myTile
4749c74143 Alis*0040 #endif /* ALLOW_EXCH2 */
aea29c8517 Alis*0041
14bb46b4fa Jean*0042 #ifdef ALLOW_AUTODIFF
                0043       DO J=1-OLy,sNy+OLy
                0044        DO I=1-OLx,sNx+OLx
629d440dd4 Patr*0045         vort3(I,J) = 0. _d 0
                0046        ENDDO
                0047       ENDDO
                0048 #endif
                0049
14bb46b4fa Jean*0050       DO J=2-OLy,sNy+OLy
                0051        DO I=2-OLx,sNx+OLx
aea29c8517 Alis*0052
                0053 C       Horizontal curl of flow field - ignoring lopping factors
                0054         vort3(I,J)=
                0055      &      recip_rAz(I,J,bi,bj)*(
f7fdcad707 Jean*0056      &      ( vFld(I,J)*dyC(I,J,bi,bj)
                0057      &       -vFld(I-1,J)*dyC(I-1,J,bi,bj) )
                0058      &     -( uFld(I,J)*dxC(I,J,bi,bj)
                0059      &       -uFld(I,J-1)*dxC(I,J-1,bi,bj) )
220a9e88b5 Jean*0060      &                           )*recip_deepFacC(k)
aea29c8517 Alis*0061
                0062 C       Horizontal curl of flow field - including lopping factors
602b37a090 Jean*0063 c       IF (hFacZ(i,j).NE.0.) THEN
aea29c8517 Alis*0064 c        vort3(I,J)=
                0065 c    &      recip_rAz(I,J,bi,bj)*(
                0066 c    &      vFld(I,J)*dyc(I,J,bi,bj)*_hFacW(i,j,k,bi,bj)
                0067 c    &     -vFld(I-1,J)*dyc(I-1,J,bi,bj)*_hFacW(i-1,j,k,bi,bj)
                0068 c    &     -uFld(I,J)*dxc(I,J,bi,bj)*_hFacS(i,j,k,bi,bj)
                0069 c    &     +uFld(I,J-1)*dxc(I,J-1,bi,bj)*_hFacS(i,j-1,k,bi,bj)
                0070 c    &                           )
                0071 c    &                            /hFacZ(i,j)
602b37a090 Jean*0072 c       ELSE
                0073 c        vort3(I,J)=0.
                0074 c       ENDIF
aea29c8517 Alis*0075
                0076        ENDDO
                0077       ENDDO
404487e0d3 Andr*0078
aea29c8517 Alis*0079 C     Special stuff for Cubed Sphere
                0080       IF (useCubedSphereExchange) THEN
4749c74143 Alis*0081 #ifdef ALLOW_EXCH2
c424ee7cc7 Jean*0082        myTile = W2_myTileList(bi,bj)
f7fdcad707 Jean*0083        myFace = exch2_myFace(myTile)
602b37a090 Jean*0084        southWestCorner = exch2_isWedge(myTile).EQ.1
                0085      &             .AND. exch2_isSedge(myTile).EQ.1
                0086        southEastCorner = exch2_isEedge(myTile).EQ.1
                0087      &             .AND. exch2_isSedge(myTile).EQ.1
                0088        northEastCorner = exch2_isEedge(myTile).EQ.1
                0089      &             .AND. exch2_isNedge(myTile).EQ.1
                0090        northWestCorner = exch2_isWedge(myTile).EQ.1
                0091      &             .AND. exch2_isNedge(myTile).EQ.1
87d8be0814 Alis*0092 #else
f7fdcad707 Jean*0093        myFace = bi
87d8be0814 Alis*0094        southWestCorner = .TRUE.
                0095        southEastCorner = .TRUE.
                0096        northWestCorner = .TRUE.
                0097        northEastCorner = .TRUE.
4749c74143 Alis*0098 #endif /* ALLOW_EXCH2 */
f2da9de9fe Jean*0099
404487e0d3 Andr*0100        IF ( southWestCorner ) THEN
                0101 C               U(0,1)     D(0,1)      U(1,1)     TILE
                0102 C                |                      |
                0103 C   V(-1,1) --- Z(0,1) --- V(0,1) ---  Z(1,1) --- V(1,1) ---
                0104 C                |                      |
                0105 C               U(0,0)     D(0,0)      U(1,0)     D(1,0)
                0106 C                |                      |
                0107 C                      --- V(0,0) ---  Z(1,0) --- V(1,0) ---
                0108 C                                       |
                0109 C                                      U(1,-1)
aea29c8517 Alis*0110          I=1
                0111          J=1
7dd05684e1 Jean*0112 C-    to get the same truncation, independent from the face Nb,
                0113 C     do (1+2)+3, and always in the same order (exch3 convention order):
                0114          vort3(I,J)=
f7fdcad707 Jean*0115      &     +recip_rAz(I,J,bi,bj)*(
7dd05684e1 Jean*0116      &      ( vFld(I,J)*dyC(I,J,bi,bj)
                0117      &       -uFld(I,J)*dxC(I,J,bi,bj) )
                0118      &      + uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0119      &     )*recip_deepFacC(k)
f7fdcad707 Jean*0120 C-    the quick way, but do not get the same truncation on the 3 faces:
                0121 c        vort3(I,J)=
                0122 c    &     +recip_rAz(I,J,bi,bj)*(
                0123 c    &      vFld(I,J)*dyC(I,J,bi,bj)
                0124 c    &     -uFld(I,J)*dxC(I,J,bi,bj)
                0125 c    &     +uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0126 c    &     )*recip_deepFacC(k)
fc5dc5d012 Jean*0127 #ifdef CALC_CS_CORNER_EXTENDED
7dd05684e1 Jean*0128          vort3(I-1,J)=
404487e0d3 Andr*0129      &      recip_rAz(I-1,J,bi,bj)*(
f7fdcad707 Jean*0130      &      vFld(I-1,J)*dyC(I-1,J,bi,bj)
                0131      &     -vFld(I-2,J)*dyC(I-2,J,bi,bj)
                0132      &     -uFld(I-1,J)*dxC(I-1,J,bi,bj)
                0133      &     +vFld(I+0,J-1)*dyC(I+0,J-1,bi,bj)
220a9e88b5 Jean*0134      &                             )*recip_deepFacC(k)
e0f1ebae6e Jean*0135      &     *maskS(i-1,j,k,bi,bj)*maskS(i-2,j,k,bi,bj)
                0136      &     *maskW(i-1,j,k,bi,bj)*maskS(i,j-1,k,bi,bj)
7dd05684e1 Jean*0137          vort3(I,J-1)=vort3(I-1,J)
fc5dc5d012 Jean*0138 #endif
404487e0d3 Andr*0139        ENDIF
f2da9de9fe Jean*0140
404487e0d3 Andr*0141        IF ( southEastCorner ) THEN
                0142 C   TILE       U(N+1,1)     D(N+1,1)      U(N+2,1)
                0143 C               |                          |
                0144 C   V(N,1) --- Z(N+1,1) --- V(N+1,1) ---  Z(N+2,1) --- V(N+3,1) ---
                0145 C               |                          |
                0146 C   D(N,0)     U(N+1,0)     D(N+1,0)      U(N+2,0)
                0147 C               |                          |
                0148 C   V(N,0) --- Z(N+1,0) --- V(N+1,0) ---
                0149 C               |                          |
                0150 C              U(N+1,-1)
aea29c8517 Alis*0151          I=sNx+1
                0152          J=1
7dd05684e1 Jean*0153 C-    to get the same truncation, independent from the face Nb,
                0154 C      (exch3 convention order):
                0155          IF ( myFace.EQ.2 ) THEN
                0156           vort3(I,J)=
                0157      &     +recip_rAz(I,J,bi,bj)*(
                0158      &      (-uFld(I,J)*dxC(I,J,bi,bj)
                0159      &       -vFld(I-1,J)*dyC(I-1,J,bi,bj) )
                0160      &      + uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0161      &     )*recip_deepFacC(k)
7dd05684e1 Jean*0162          ELSEIF ( myFace.EQ.4 ) THEN
f7fdcad707 Jean*0163           vort3(I,J)=
                0164      &     +recip_rAz(I,J,bi,bj)*(
                0165      &      (-vFld(I-1,J)*dyC(I-1,J,bi,bj)
                0166      &       +uFld(I,J-1)*dxC(I,J-1,bi,bj) )
                0167      &      - uFld(I,J)*dxC(I,J,bi,bj)
220a9e88b5 Jean*0168      &     )*recip_deepFacC(k)
7dd05684e1 Jean*0169          ELSE
f7fdcad707 Jean*0170           vort3(I,J)=
                0171      &     +recip_rAz(I,J,bi,bj)*(
                0172      &      (+uFld(I,J-1)*dxC(I,J-1,bi,bj)
                0173      &       -uFld(I,J)*dxC(I,J,bi,bj)     )
                0174      &      - vFld(I-1,J)*dyC(I-1,J,bi,bj)
220a9e88b5 Jean*0175      &     )*recip_deepFacC(k)
f7fdcad707 Jean*0176          ENDIF
                0177 C-    the quick way, but do not get the same truncation on the 3 faces:
                0178 c        vort3(I,J)=
                0179 c    &     +recip_rAz(I,J,bi,bj)*(
                0180 c    &     -vFld(I-1,J)*dyC(I-1,J,bi,bj)
                0181 c    &     -uFld(I,J)*dxC(I,J,bi,bj)
                0182 c    &     +uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0183 c    &     )*recip_deepFacC(k)
fc5dc5d012 Jean*0184 #ifdef CALC_CS_CORNER_EXTENDED
7dd05684e1 Jean*0185          vort3(I+1,J)=
404487e0d3 Andr*0186      &      recip_rAz(I+1,J,bi,bj)*(
f7fdcad707 Jean*0187      &      vFld(I+1,J)*dyC(I+1,J,bi,bj)
                0188      &     -vFld(I-0,J)*dyC(I-0,J,bi,bj)
                0189      &     -uFld(I+1,J)*dxC(I+1,J,bi,bj)
                0190      &     -vFld(I-1,J-1)*dyC(I-1,J-1,bi,bj)
220a9e88b5 Jean*0191      &                           )*recip_deepFacC(k)
e0f1ebae6e Jean*0192      &     *maskS(i+1,j,k,bi,bj)*maskS(i-0,j,k,bi,bj)
                0193      &     *maskW(i+1,j,k,bi,bj)*maskS(i-1,j-1,k,bi,bj)
7dd05684e1 Jean*0194          vort3(I,J-1)=vort3(I+1,J)
fc5dc5d012 Jean*0195 #endif
404487e0d3 Andr*0196        ENDIF
f2da9de9fe Jean*0197
404487e0d3 Andr*0198        IF ( northWestCorner ) THEN
                0199 C                                            U(1,N+2)
                0200 C                                             |
                0201 C                          --- V(0,N+1) ---  Z(1,N+2) --- V(1,N+2) ---
                0202 C                  |                          |
                0203 C                 U(0,N+1)     D(0,N+1)      U(1,N+1)     D(1,N+1)
                0204 C                  |                          |
                0205 C   V(-1,N+1) --- Z(0,N+1) --- V(0,N+1) ---  Z(1,N+1) --- V(1,N+1) ---
                0206 C                  |                          |
                0207 C                 U(0,N)       D(0,N)        U(1,N)       TILE
aea29c8517 Alis*0208          I=1
                0209          J=sNy+1
7dd05684e1 Jean*0210 C-    to get the same truncation, independent from the face Nb,
                0211 C      (exch3 convention order):
f7fdcad707 Jean*0212          IF ( myFace.EQ.1 ) THEN
                0213           vort3(I,J)=
aea29c8517 Alis*0214      &     +recip_rAz(I,J,bi,bj)*(
7dd05684e1 Jean*0215      &      (+uFld(I,J-1)*dxC(I,J-1,bi,bj)
                0216      &       +vFld(I,J)*dyC(I,J,bi,bj)     )
                0217      &       -uFld(I,J)*dxC(I,J,bi,bj)
220a9e88b5 Jean*0218      &     )*recip_deepFacC(k)
7dd05684e1 Jean*0219          ELSEIF ( myFace.EQ.3 ) THEN
f7fdcad707 Jean*0220           vort3(I,J)=
                0221      &     +recip_rAz(I,J,bi,bj)*(
                0222      &      (-uFld(I,J)*dxC(I,J,bi,bj)
                0223      &       +uFld(I,J-1)*dxC(I,J-1,bi,bj) )
                0224      &      + vFld(I,J)*dyC(I,J,bi,bj)
220a9e88b5 Jean*0225      &     )*recip_deepFacC(k)
f7fdcad707 Jean*0226          ELSE
                0227           vort3(I,J)=
                0228      &     +recip_rAz(I,J,bi,bj)*(
7dd05684e1 Jean*0229      &      (+vFld(I,J)*dyC(I,J,bi,bj)
                0230      &       -uFld(I,J)*dxC(I,J,bi,bj)     )
                0231      &      + uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0232      &     )*recip_deepFacC(k)
f7fdcad707 Jean*0233          ENDIF
                0234 C-    the quick way, but do not get the same truncation on the 3 faces:
                0235 c        vort3(I,J)=
                0236 c    &     +recip_rAz(I,J,bi,bj)*(
                0237 c    &      vFld(I,J)*dyC(I,J,bi,bj)
                0238 c    &     -uFld(I,J)*dxC(I,J,bi,bj)
                0239 c    &     +uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0240 c    &     )*recip_deepFacC(k)
fc5dc5d012 Jean*0241 #ifdef CALC_CS_CORNER_EXTENDED
7dd05684e1 Jean*0242          vort3(I-1,J)=
404487e0d3 Andr*0243      &      recip_rAz(I-1,J,bi,bj)*(
f7fdcad707 Jean*0244      &      vFld(I-1,J)*dyC(I-1,J,bi,bj)
                0245      &     -vFld(I-2,J)*dyC(I-2,J,bi,bj)
                0246      &     +vFld(I-0,J+1)*dyC(I-0,J+1,bi,bj)
                0247      &     +uFld(I-1,J-1)*dxC(I-1,J-1,bi,bj)
220a9e88b5 Jean*0248      &                           )*recip_deepFacC(k)
e0f1ebae6e Jean*0249      &     *maskS(i-1,j,k,bi,bj)*maskS(i-2,j,k,bi,bj)
                0250      &     *maskS(i,j+1,k,bi,bj)*maskW(i-1,j-1,k,bi,bj)
7dd05684e1 Jean*0251          vort3(I,J+1)=vort3(I-1,J)
fc5dc5d012 Jean*0252 #endif
e0f1ebae6e Jean*0253        ENDIF
f2da9de9fe Jean*0254
e0f1ebae6e Jean*0255        IF ( northEastCorner ) THEN
404487e0d3 Andr*0256 C                U(N+1,N+2)
                0257 C                 |                              |
                0258 C   V(N,N+2) --- Z(N+1,N+2) --- V(N+1,N+2) ---
                0259 C                 |                              |
                0260 C   D(N,N+1)     U(N+1,N+1)     D(N+1,N+1)      U(N+2,N+1)
                0261 C                 |                              |
                0262 C   V(N,N+1) --- Z(N+1,N+1) --- V(N+1,N+1) ---  Z(N+2,N+1) --- V(N+3,N+1) ---
                0263 C                 |                              |
                0264 C   TILE         U(N+1,N)       D(N+1,N)        U(N+2,N)
aea29c8517 Alis*0265          I=sNx+1
                0266          J=sNy+1
f7fdcad707 Jean*0267 C-    to get the same truncation, independent from the face Nb:
7dd05684e1 Jean*0268 C      (exch3 convention order):
f7fdcad707 Jean*0269          IF ( MOD(myFace,2).EQ.1 ) THEN
                0270           vort3(I,J)=
                0271      &     +recip_rAz(I,J,bi,bj)*(
7dd05684e1 Jean*0272      &      (-uFld(I,J)*dxC(I,J,bi,bj)
                0273      &       -vFld(I-1,J)*dyC(I-1,J,bi,bj) )
                0274      &      + uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0275      &     )*recip_deepFacC(k)
f7fdcad707 Jean*0276          ELSE
                0277           vort3(I,J)=
aea29c8517 Alis*0278      &     +recip_rAz(I,J,bi,bj)*(
7dd05684e1 Jean*0279      &      (+uFld(I,J-1)*dxC(I,J-1,bi,bj)
                0280      &       -uFld(I,J)*dxC(I,J,bi,bj)     )
                0281      &      - vFld(I-1,J)*dyC(I-1,J,bi,bj)
220a9e88b5 Jean*0282      &     )*recip_deepFacC(k)
f7fdcad707 Jean*0283          ENDIF
                0284 C-    the quick way, but do not get the same truncation on the 3 faces:
                0285 c        vort3(I,J)=
                0286 c    &     +recip_rAz(I,J,bi,bj)*(
                0287 c    &     -vFld(I-1,J)*dyC(I-1,J,bi,bj)
                0288 c    &     -uFld(I,J)*dxC(I,J,bi,bj)
                0289 c    &     +uFld(I,J-1)*dxC(I,J-1,bi,bj)
220a9e88b5 Jean*0290 c    &     )*recip_deepFacC(k)
fc5dc5d012 Jean*0291 #ifdef CALC_CS_CORNER_EXTENDED
7dd05684e1 Jean*0292          vort3(I+1,J)=
404487e0d3 Andr*0293      &      recip_rAz(I+1,J,bi,bj)*(
f7fdcad707 Jean*0294      &      vFld(I+1,J)*dyC(I+1,J,bi,bj)
                0295      &     -vFld(I-0,J)*dyC(I-0,J,bi,bj)
                0296      &     -vFld(I-1,J+1)*dyC(I-1,J+1,bi,bj)
                0297      &     +uFld(I+1,J-1)*dxC(I+1,J-1,bi,bj)
220a9e88b5 Jean*0298      &                           )*recip_deepFacC(k)
e0f1ebae6e Jean*0299      &     *maskS(i+1,j,k,bi,bj)*maskS(i-0,j,k,bi,bj)
                0300      &     *maskS(i-1,j+1,k,bi,bj)*maskW(i+1,j-1,k,bi,bj)
7dd05684e1 Jean*0301          vort3(I,J+1)=vort3(I+1,J)
fc5dc5d012 Jean*0302 #endif
aea29c8517 Alis*0303        ENDIF
e0f1ebae6e Jean*0304       ENDIF
aea29c8517 Alis*0305
                0306       RETURN
                0307       END