pkg/shap_filt/shap_filt_tracer_s4.F

aea29c8517 Alis*0001 #include "SHAP_FILT_OPTIONS.h"
15c70d7cd1 Jean*0002
                0003 CBOP
                0004 C     !ROUTINE: SHAP_FILT_TRACER_S4
                0005 C     !INTERFACE:
                0006       SUBROUTINE SHAP_FILT_TRACER_S4(
                0007      U           field, tmpFld,
fb09a37055 Jean*0008      I           nShapTr, kSize, myTime, myThid )
15c70d7cd1 Jean*0009 C     !DESCRIPTION: \bv
                0010 C     *==========================================================*
                0011 C     | S/R SHAP_FILT_TRACER_S4
                0012 C     | o Applies Shapiro filter to tracer field (cell center).
                0013 C     | o use filtering function "S4" = [1 - d_xx^n][1- d_yy^n]
                0014 C     |     with no grid spacing (computational Filter)
                0015 C     *==========================================================*
                0016 C     \ev
                0017
                0018 C     !USES:
aea29c8517 Alis*0019       IMPLICIT NONE
15c70d7cd1 Jean*0020
aea29c8517 Alis*0021 C     == Global variables ===
                0022 #include "SIZE.h"
                0023 #include "EEPARAMS.h"
                0024 #include "PARAMS.h"
                0025 #include "GRID.h"
                0026 #include "SHAP_FILT.h"
                0027
15c70d7cd1 Jean*0028 C     !INPUT/OUTPUT PARAMETERS:
aea29c8517 Alis*0029 C     == Routine arguments
15c70d7cd1 Jean*0030 C     field :: cell-centered 2D field on which filter applies
                0031 C     tmpFld :: working temporary array
fb09a37055 Jean*0032 C     nShapTr :: (total) power of the filter for this tracer
15c70d7cd1 Jean*0033 C     kSize :: length of 3rd Dim : either =1 (2D field) or =Nr (3D field)
                0034 C     myTime :: Current time in simulation
                0035 C     myThid :: Thread number for this instance of SHAP_FILT_TRACER_S4
fb09a37055 Jean*0036       INTEGER nShapTr, kSize
15c70d7cd1 Jean*0037       _RL field(1-OLx:sNx+OLx,1-OLy:sNy+OLy,kSize,nSx,nSy)
                0038       _RL tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,kSize,nSx,nSy)
aea29c8517 Alis*0039       _RL     myTime
                0040       INTEGER myThid
15c70d7cd1 Jean*0041
aea29c8517 Alis*0042 #ifdef ALLOW_SHAP_FILT
                0043
15c70d7cd1 Jean*0044 C     !LOCAL VARIABLES:
aea29c8517 Alis*0045 C     == Local variables ==
                0046       INTEGER bi,bj,K,I,J,N
                0047       _RL tmpGrd(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
15c70d7cd1 Jean*0048 CEOP
aea29c8517 Alis*0049
fb09a37055 Jean*0050       IF (nShapTr.gt.0) THEN
aea29c8517 Alis*0051
                0052         DO bj=myByLo(myThid),myByHi(myThid)
                0053          DO bi=myBxLo(myThid),myBxHi(myThid)
15c70d7cd1 Jean*0054           DO K=1,kSize
                0055            DO J=1-OLy,sNy+Oly
                0056             DO I=1-Olx,sNx+Olx
aea29c8517 Alis*0057              tmpFld(i,j,k,bi,bj)=field(i,j,k,bi,bj)
                0058             ENDDO
                0059            ENDDO
                0060           ENDDO
                0061          ENDDO
                0062         ENDDO
                0063
                0064
                0065 C      d_xx^n tmpFld
                0066
fb09a37055 Jean*0067        DO N=1,nShapTr
aea29c8517 Alis*0068
15c70d7cd1 Jean*0069         IF (kSize.EQ.Nr) THEN
7163a40534 Jean*0070           _EXCH_XYZ_RL( tmpFld, myThid )
15c70d7cd1 Jean*0071         ELSE
7163a40534 Jean*0072           _EXCH_XY_RL( tmpFld, myThid )
15c70d7cd1 Jean*0073         ENDIF
aea29c8517 Alis*0074
                0075         DO bj=myByLo(myThid),myByHi(myThid)
                0076          DO bi=myBxLo(myThid),myBxHi(myThid)
15c70d7cd1 Jean*0077           DO K=1,kSize
aea29c8517 Alis*0078
                0079            DO J=1,sNy
                0080             DO I=1,sNx
                0081              tmpGrd(i,j) = -0.25*(
                0082      &        ( tmpFld(i+1,j,k,bi,bj)-tmpFld( i ,j,k,bi,bj) )
                0083      &            *_maskW(i+1,j,k,bi,bj)
                0084      &       -( tmpFld( i ,j,k,bi,bj)-tmpFld(i-1,j,k,bi,bj) )
                0085      &            *_maskW(i,j,k,bi,bj) )
                0086             ENDDO
                0087            ENDDO
                0088
                0089            DO J=1,sNy
                0090             DO I=1,sNx
                0091              tmpFld(i,j,k,bi,bj) = tmpGrd(i,j)
                0092             ENDDO
                0093            ENDDO
                0094
                0095           ENDDO
                0096          ENDDO
                0097         ENDDO
                0098
                0099        ENDDO
                0100
15c70d7cd1 Jean*0101 C      F <-  [1 - d_xx^n *deltaT/tau].F
aea29c8517 Alis*0102        DO bj=myByLo(myThid),myByHi(myThid)
                0103         DO bi=myBxLo(myThid),myBxHi(myThid)
15c70d7cd1 Jean*0104          DO K=1,kSize
aea29c8517 Alis*0105           DO J=1,sNy
                0106            DO I=1,sNx
15c70d7cd1 Jean*0107             field(i,j,k,bi,bj)=field(i,j,k,bi,bj)
dfc17c9c63 Jean*0108      &              -tmpFld(i,j,k,bi,bj)*dTtracerLev(1)/Shap_Trtau
15c70d7cd1 Jean*0109             tmpFld(i,j,k,bi,bj)=field(i,j,k,bi,bj)
aea29c8517 Alis*0110            ENDDO
                0111           ENDDO
                0112          ENDDO
                0113         ENDDO
                0114        ENDDO
                0115
                0116
                0117 C      d_yy^n tmpFld
                0118
fb09a37055 Jean*0119        DO N=1,nShapTr
aea29c8517 Alis*0120
15c70d7cd1 Jean*0121         IF (kSize.EQ.1) THEN
7163a40534 Jean*0122           _EXCH_XY_RL( tmpFld, myThid )
15c70d7cd1 Jean*0123         ELSE
7163a40534 Jean*0124           _EXCH_XYZ_RL( tmpFld, myThid )
15c70d7cd1 Jean*0125         ENDIF
aea29c8517 Alis*0126
                0127         DO bj=myByLo(myThid),myByHi(myThid)
                0128          DO bi=myBxLo(myThid),myBxHi(myThid)
15c70d7cd1 Jean*0129           DO K=1,kSize
aea29c8517 Alis*0130
                0131            DO J=1,sNy
                0132             DO I=1,sNx
                0133              tmpGrd(i,j) = -0.25*(
                0134      &        ( tmpFld(i,j+1,k,bi,bj)-tmpFld(i, j ,k,bi,bj) )
                0135      &            *_maskS(i,j+1,k,bi,bj)
                0136      &       -( tmpFld(i, j ,k,bi,bj)-tmpFld(i,j-1,k,bi,bj) )
                0137      &            *_maskS(i,j,k,bi,bj) )
                0138             ENDDO
                0139            ENDDO
                0140
                0141            DO J=1,sNy
                0142             DO I=1,sNx
                0143              tmpFld(i,j,k,bi,bj) = tmpGrd(i,j)
                0144             ENDDO
                0145            ENDDO
                0146
                0147           ENDDO
                0148          ENDDO
                0149         ENDDO
                0150
                0151        ENDDO
                0152
15c70d7cd1 Jean*0153 C      F <-  [1 - d_yy^n *deltaT/tau].F
aea29c8517 Alis*0154        DO bj=myByLo(myThid),myByHi(myThid)
                0155         DO bi=myBxLo(myThid),myBxHi(myThid)
15c70d7cd1 Jean*0156          DO K=1,kSize
aea29c8517 Alis*0157           DO J=1,sNy
                0158            DO I=1,sNx
15c70d7cd1 Jean*0159             field(i,j,k,bi,bj)=field(i,j,k,bi,bj)
dfc17c9c63 Jean*0160      &              -tmpFld(i,j,k,bi,bj)*dTtracerLev(1)/Shap_Trtau
aea29c8517 Alis*0161            ENDDO
                0162           ENDDO
                0163          ENDDO
                0164         ENDDO
                0165        ENDDO
                0166
15c70d7cd1 Jean*0167         IF (kSize.EQ.Nr) THEN
7163a40534 Jean*0168           _EXCH_XYZ_RL( field, myThid )
15c70d7cd1 Jean*0169         ELSEIF (kSize.EQ.1) THEN
7163a40534 Jean*0170           _EXCH_XY_RL( field, myThid )
15c70d7cd1 Jean*0171         ELSE
                0172           STOP 'S/R SHAP_FILT_TRACER_S4: kSize is wrong'
                0173         ENDIF
aea29c8517 Alis*0174
                0175       ENDIF
                0176 #endif /* ALLOW_SHAP_FILT */
                0177
                0178       RETURN
                0179       END