pkg/shap_filt/shap_filt_apply_ts.F

49bf680eba Jean*0001 #include "SHAP_FILT_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: SHAP_FILT_APPLY_TS
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE SHAP_FILT_APPLY_TS(
                0008      U                     tFld, sFld,
                0009      I                     myTime, myIter, myThid )
                0010
                0011 C !DESCRIPTION:
                0012 C Apply a Shapiro filter on active tracers tFld & sFld
                0013
                0014 C !USES: ===============================================================
                0015       IMPLICIT NONE
                0016
                0017 #include "SIZE.h"
                0018 #include "EEPARAMS.h"
                0019 #include "PARAMS.h"
                0020 #include "DYNVARS.h"
                0021 #include "GRID.h"
                0022 #include "SHAP_FILT.h"
                0023
                0024 C !INPUT PARAMETERS: ===================================================
                0025 C  myTime               :: current time
                0026 C  myIter               :: iteration number
                0027 C  myThid               :: thread number
                0028       _RL myTime
                0029       INTEGER myIter
                0030       INTEGER myThid
                0031
                0032 C !INPUT/OUTPUT PARAMETERS: ============================================
                0033 C tFld                  :: input and filtered temperature field
                0034 C sFld                  :: input and filtered salinity field
                0035       _RL  tFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0036       _RL  sFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0037
                0038 #ifdef ALLOW_SHAP_FILT
                0039
94a46dfe0d Jean*0040       LOGICAL  DIFFERENT_MULTIPLE
                0041       EXTERNAL DIFFERENT_MULTIPLE
00177dc887 Jean*0042
49bf680eba Jean*0043 C !LOCAL VARIABLES: ====================================================
d11f474de4 Jean*0044 C     == Local variables ==
00177dc887 Jean*0045 #ifdef USE_OLD_SHAPIRO_FILTERS
d11f474de4 Jean*0046 C     bi,bj,k :: loop index
                0047       INTEGER bi, bj, k
                0048 #endif /* USE_OLD_SHAPIRO_FILTERS */
e93c2e7dac Jean*0049       INTEGER exchInOut
af20bc5e19 Jean*0050       CHARACTER*(10) suff
49bf680eba Jean*0051 CEOP
                0052
fb09a37055 Jean*0053       IF (nShapT.GT.0 .OR. nShapS.GT.0) THEN
49bf680eba Jean*0054
e93c2e7dac Jean*0055 C-    Apply Exchanges on Input field, before the filter (but not after):
                0056         exchInOut = 1
                0057 C-    Apply Exchanges on Output field, after the filter (but not before):
                0058         IF ( implicitIntGravWave ) exchInOut = 2
                0059
36d530816f Jean*0060 #ifdef USE_OLD_SHAPIRO_FILTERS
                0061
7163a40534 Jean*0062         IF ( tempStepping ) _EXCH_XYZ_RL( tFld,myThid )
                0063         IF ( saltStepping ) _EXCH_XYZ_RL( sFld,myThid )
36d530816f Jean*0064
                0065         DO bj=myByLo(myThid),myByHi(myThid)
                0066          DO bi=myBxLo(myThid),myBxHi(myThid)
                0067           DO k=1, Nr
ae409e69d3 Jean*0068             IF ( tempStepping )
36d530816f Jean*0069      &       CALL SHAP_FILT_TRACEROLD( tFld,bi,bj,k,myTime,myThid )
ae409e69d3 Jean*0070             IF ( saltStepping )
36d530816f Jean*0071      &       CALL SHAP_FILT_TRACEROLD( sFld,bi,bj,k,myTime,myThid )
                0072           ENDDO
                0073          ENDDO
                0074         ENDDO
                0075
7163a40534 Jean*0076         IF ( tempStepping ) _EXCH_XYZ_RL( tFld,myThid )
                0077         IF ( saltStepping ) _EXCH_XYZ_RL( sFld,myThid )
36d530816f Jean*0078
                0079 #else
                0080
49bf680eba Jean*0081         IF ( tempStepping .AND. nShapT.GT.0) THEN
                0082           IF (Shap_funct.EQ.1) THEN
                0083             CALL SHAP_FILT_TRACER_S1(
d11f474de4 Jean*0084      U           tFld, Shap_tmpFld1,
fb09a37055 Jean*0085      I           nShapT, Nr, myTime, myThid )
ae409e69d3 Jean*0086           ELSEIF (Shap_funct.EQ.2 .OR. Shap_funct.EQ.20
                0087      &                            .OR. Shap_funct.EQ.21) THEN
49bf680eba Jean*0088             CALL SHAP_FILT_TRACER_S2(
d11f474de4 Jean*0089      U           tFld, Shap_tmpFld1,
e93c2e7dac Jean*0090      I           nShapT, exchInOut, Nr, myTime, myIter, myThid )
49bf680eba Jean*0091           ELSEIF (Shap_funct.EQ.4) THEN
                0092             CALL SHAP_FILT_TRACER_S4(
d11f474de4 Jean*0093      U           tFld, Shap_tmpFld1,
fb09a37055 Jean*0094      I           nShapT, Nr, myTime, myThid )
ae409e69d3 Jean*0095 c         ELSEIF (Shap_funct.EQ.20) THEN
                0096 c           CALL SHAP_FILT_TRACER_S2G(
                0097 c    U           tFld, Shap_tmpFld1,
                0098 c    I           nShapT, Nr, myTime, myThid )
49bf680eba Jean*0099           ELSE
d11f474de4 Jean*0100            STOP 'SHAP_FILT_APPLY_TS: Ooops! Bad Shap_funct in T block'
49bf680eba Jean*0101           ENDIF
00177dc887 Jean*0102
                0103 C-----    Diagnostic of Shapiro Filter effect on temperature :
                0104 C         Note: Shap_tmpFld1 from shap_filt_tracer_s2 (and not s1, s4)
                0105 C               is directly proportional to Delta-Tr due to the Filter
                0106           IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4 .AND.
94a46dfe0d Jean*0107      &     DIFFERENT_MULTIPLE(Shap_diagFreq,myTime,deltaTClock)
00177dc887 Jean*0108      &       ) THEN
                0109            _BARRIER
af20bc5e19 Jean*0110            IF ( rwSuffixType.EQ.0 ) THEN
                0111              WRITE(suff,'(I10.10)') myIter
                0112            ELSE
                0113              CALL RW_GET_SUFFIX( suff, myTime, myIter, myThid )
                0114            ENDIF
00177dc887 Jean*0115            CALL WRITE_FLD_XYZ_RL( 'shap_dT.', suff, Shap_tmpFld1,
                0116      &                            myIter, myThid)
                0117            _BARRIER
                0118           ENDIF
                0119
64e64319fa Jean*0120 #ifdef ALLOW_DIAGNOSTICS
                0121           IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4
                0122      &                         .AND. useDiagnostics ) THEN
                0123             CALL DIAGNOSTICS_FILL(Shap_tmpFld1,'SHAP_dT ',0,Nr,
                0124      &                                                  0,1,1,myThid)
                0125           ENDIF
                0126 #endif /* ALLOW_DIAGNOSTICS */
                0127
49bf680eba Jean*0128         ENDIF
36d530816f Jean*0129
ae409e69d3 Jean*0130         IF ( saltStepping .AND. nShapS.GT.0) THEN
49bf680eba Jean*0131           IF (Shap_funct.EQ.1) THEN
                0132             CALL SHAP_FILT_TRACER_S1(
d11f474de4 Jean*0133      U           sFld, Shap_tmpFld1,
fb09a37055 Jean*0134      I           nShapS, Nr, myTime, myThid )
ae409e69d3 Jean*0135           ELSEIF (Shap_funct.EQ.2 .OR. Shap_funct.EQ.20
                0136      &                            .OR. Shap_funct.EQ.21) THEN
49bf680eba Jean*0137             CALL SHAP_FILT_TRACER_S2(
d11f474de4 Jean*0138      U           sFld, Shap_tmpFld1,
e93c2e7dac Jean*0139      I           nShapS, exchInOut, Nr, myTime, myIter, myThid )
49bf680eba Jean*0140           ELSEIF (Shap_funct.EQ.4) THEN
                0141             CALL SHAP_FILT_TRACER_S4(
d11f474de4 Jean*0142      U           sFld, Shap_tmpFld1,
fb09a37055 Jean*0143      I           nShapS, Nr, myTime, myThid )
ae409e69d3 Jean*0144 c         ELSEIF (Shap_funct.EQ.20) THEN
                0145 c           CALL SHAP_FILT_TRACER_S2G(
                0146 c    U           sFld, Shap_tmpFld1,
                0147 c    I           nShapS, Nr, myTime, myThid )
49bf680eba Jean*0148           ELSE
d11f474de4 Jean*0149            STOP 'SHAP_FILT_APPLY_TS: Ooops! Bad Shap_funct in S block'
49bf680eba Jean*0150           ENDIF
00177dc887 Jean*0151
                0152 C-----    Diagnostic of Shapiro Filter effect on salinity :
e93c2e7dac Jean*0153 C         Note: Shap_tmpFld1 from shap_filt_tracer_s2 (and not s1, s4)
00177dc887 Jean*0154 C               is directly proportional to Delta-Tr due to the Filter
                0155           IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4 .AND.
94a46dfe0d Jean*0156      &     DIFFERENT_MULTIPLE(Shap_diagFreq,myTime,deltaTClock)
00177dc887 Jean*0157      &       ) THEN
                0158            _BARRIER
af20bc5e19 Jean*0159            IF ( rwSuffixType.EQ.0 ) THEN
                0160              WRITE(suff,'(I10.10)') myIter
                0161            ELSE
                0162              CALL RW_GET_SUFFIX( suff, myTime, myIter, myThid )
                0163            ENDIF
00177dc887 Jean*0164            CALL WRITE_FLD_XYZ_RL( 'shap_dS.', suff, Shap_tmpFld1,
                0165      &                            myIter, myThid)
                0166            _BARRIER
                0167           ENDIF
                0168
64e64319fa Jean*0169 #ifdef ALLOW_DIAGNOSTICS
                0170           IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4
                0171      &                         .AND. useDiagnostics ) THEN
                0172             CALL DIAGNOSTICS_FILL(Shap_tmpFld1,'SHAP_dS ',0,Nr,
                0173      &                                                  0,1,1,myThid)
                0174           ENDIF
                0175 #endif /* ALLOW_DIAGNOSTICS */
                0176
49bf680eba Jean*0177         ENDIF
                0178
                0179 #endif /* USE_OLD_SHAPIRO_FILTERS */
36d530816f Jean*0180
                0181       ENDIF
                0182
49bf680eba Jean*0183 #endif /* ALLOW_SHAP_FILT */
                0184
                0185       RETURN
                0186       END