pkg/shap_filt/shap_filt_apply_uv.F

36d530816f Jean*0001 #include "SHAP_FILT_OPTIONS.h"
                0002
d11f474de4 Jean*0003 CBOP
                0004 C     !ROUTINE: SHAP_FILT_APPLY_UV
                0005 C     !INTERFACE:
36d530816f Jean*0006       SUBROUTINE SHAP_FILT_APPLY_UV(
                0007      U                     uFld, vFld,
                0008      I                     myTime, myIter, myThid )
d11f474de4 Jean*0009
                0010 C     !DESCRIPTION: \bv
                0011 C     *==========================================================*
                0012 C     | S/R SHAP_FILT_cwAPPLY_UV
8b25254c4a Jean*0013 C     | o Apply Shapiro filter on momentum :
d11f474de4 Jean*0014 C     |   filter the argments uFld & vFld.
                0015 C     *==========================================================*
                0016 C     \ev
ae409e69d3 Jean*0017
d11f474de4 Jean*0018 C     !USES:
36d530816f Jean*0019       IMPLICIT NONE
                0020
                0021 C     == Global variables ===
                0022 #include "SIZE.h"
                0023 #include "EEPARAMS.h"
                0024 #include "PARAMS.h"
d11f474de4 Jean*0025 c #include "DYNVARS.h"
36d530816f Jean*0026 #include "GRID.h"
                0027 #include "SHAP_FILT.h"
8b25254c4a Jean*0028 #ifdef ALLOW_FRICTION_HEATING
                0029 # include "FFIELDS.h"
                0030 #endif
36d530816f Jean*0031
d11f474de4 Jean*0032 C     !INPUT/OUTPUT PARAMETERS:
36d530816f Jean*0033 C     == Routine arguments ==
d11f474de4 Jean*0034 C     uFld :: velocity field (U component) on which filter applies
                0035 C     vFld :: velocity field (V component) on which filter applies
                0036 C     myTime :: Current time in simulation
                0037 C     myIter :: Current iteration number in simulation
                0038 C     myThid :: Thread number for this instance of SHAP_FILT_APPLY_UV
36d530816f Jean*0039       _RL  uFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0040       _RL  vFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0041       _RL myTime
                0042       INTEGER myIter
d11f474de4 Jean*0043       INTEGER myThid
36d530816f Jean*0044
                0045 #ifdef ALLOW_SHAP_FILT
d11f474de4 Jean*0046
8b25254c4a Jean*0047 C     !FUNCTIONS:
94a46dfe0d Jean*0048       LOGICAL  DIFFERENT_MULTIPLE
                0049       EXTERNAL DIFFERENT_MULTIPLE
8b25254c4a Jean*0050 #ifdef ALLOW_DIAGNOSTICS
                0051       LOGICAL  DIAGNOSTICS_IS_ON
                0052       EXTERNAL DIAGNOSTICS_IS_ON
                0053 #endif /* ALLOW_DIAGNOSTICS */
00177dc887 Jean*0054
d11f474de4 Jean*0055 C     !LOCAL VARIABLES:
                0056 C     == Local variables ==
00177dc887 Jean*0057 #ifdef USE_OLD_SHAPIRO_FILTERS
d11f474de4 Jean*0058 C     bi,bj,k :: loop index
36d530816f Jean*0059       INTEGER bi, bj, k
8b25254c4a Jean*0060 #else /* USE_OLD_SHAPIRO_FILTERS */
                0061       LOGICAL diag_dKE
af20bc5e19 Jean*0062       CHARACTER*(10) suff
8b25254c4a Jean*0063 #if ( defined ALLOW_FRICTION_HEATING ) || ( defined ALLOW_DIAGNOSTICS )
73e3454c50 Davi*0064       INTEGER bi, bj, k, i, j
8b25254c4a Jean*0065       _RL dKE_shap(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0066 #endif
                0067 #endif /* USE_OLD_SHAPIRO_FILTERS */
d11f474de4 Jean*0068 CEOP
                0069
8b25254c4a Jean*0070       IF ( momStepping .AND. nShapUV.GT.0) THEN
36d530816f Jean*0071
                0072 #ifdef  USE_OLD_SHAPIRO_FILTERS
7163a40534 Jean*0073         _EXCH_XYZ_RL( uFld,myThid )
                0074         _EXCH_XYZ_RL( vFld,myThid )
36d530816f Jean*0075
                0076         DO bj=myByLo(myThid),myByHi(myThid)
                0077          DO bi=myBxLo(myThid),myBxHi(myThid)
                0078           DO k=1, Nr
                0079             CALL SHAP_FILT_U( uFld,bi,bj,k,myTime,myThid )
                0080             CALL SHAP_FILT_V( vFld,bi,bj,k,myTime,myThid )
                0081           ENDDO
                0082          ENDDO
                0083         ENDDO
                0084
7163a40534 Jean*0085         _EXCH_XYZ_RL( uFld,myThid )
                0086         _EXCH_XYZ_RL( vFld,myThid )
36d530816f Jean*0087 #else
8b25254c4a Jean*0088         IF (Shap_funct.EQ.1) THEN
                0089           CALL SHAP_FILT_UV_S1(
d11f474de4 Jean*0090      U           uFld, vFld, Shap_tmpFld1, Shap_tmpFld2,
                0091      I           Nr, myTime, myThid )
8b25254c4a Jean*0092         ELSEIF (Shap_funct.EQ.2 .OR. Shap_funct.EQ.20) THEN
                0093           CALL SHAP_FILT_UV_S2(
d11f474de4 Jean*0094      U           uFld, vFld, Shap_tmpFld1, Shap_tmpFld2,
                0095      I           Nr, myTime, myThid )
8b25254c4a Jean*0096         ELSEIF (Shap_funct.EQ.4) THEN
                0097           CALL SHAP_FILT_UV_S4(
d11f474de4 Jean*0098      U           uFld, vFld, Shap_tmpFld1, Shap_tmpFld2,
                0099      I           Nr, myTime, myThid )
8b25254c4a Jean*0100 c       ELSEIF (Shap_funct.EQ.20) THEN
                0101 c         CALL SHAP_FILT_UV_S2G(
ae409e69d3 Jean*0102 c    U           uFld, vFld, Shap_tmpFld1, Shap_tmpFld2,
                0103 c    I           Nr, myTime, myThid )
8b25254c4a Jean*0104         ELSEIF (Shap_funct.EQ.21) THEN
                0105           CALL SHAP_FILT_UV_S2C(
d11f474de4 Jean*0106      U           uFld, vFld, Shap_tmpFld1, Shap_tmpFld2,
                0107      I           Nr, myTime, myThid )
8b25254c4a Jean*0108         ELSE
d11f474de4 Jean*0109            STOP 'SHAP_FILT_APPLY_UV: Ooops! Bad Shap_funct in UV block'
8b25254c4a Jean*0110         ENDIF
00177dc887 Jean*0111
8b25254c4a Jean*0112 C-----  Diagnostic of Shapiro Filter effect on Momentum :
                0113 C       Note: Shap_tmpFld1,2 from shap_filt_tracer_s2 (and not s1, s4)
                0114 C             are directly proportional to Delta-U,V due to the Filter
                0115         IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4 .AND.
94a46dfe0d Jean*0116      &     DIFFERENT_MULTIPLE(Shap_diagFreq,myTime,deltaTClock)
8b25254c4a Jean*0117      &     ) THEN
af20bc5e19 Jean*0118           IF ( rwSuffixType.EQ.0 ) THEN
                0119             WRITE(suff,'(I10.10)') myIter
                0120           ELSE
                0121             CALL RW_GET_SUFFIX( suff, myTime, myIter, myThid )
                0122           ENDIF
8b25254c4a Jean*0123           CALL WRITE_FLD_XYZ_RL( 'shap_dU.', suff, Shap_tmpFld1,
                0124      &                            myIter,myThid)
                0125           CALL WRITE_FLD_XYZ_RL( 'shap_dV.', suff, Shap_tmpFld2,
                0126      &                            myIter,myThid)
                0127         ENDIF
00177dc887 Jean*0128
8b25254c4a Jean*0129         IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4 .AND.
                0130      &       ( addFrictionHeating .OR. useDiagnostics ) ) THEN
                0131          diag_dKE = .FALSE.
64e64319fa Jean*0132 #ifdef ALLOW_DIAGNOSTICS
8b25254c4a Jean*0133          IF ( useDiagnostics ) THEN
                0134            CALL DIAGNOSTICS_FILL( Shap_tmpFld1, 'SHAP_dU ', 0, Nr,
                0135      &                                           0, 1, 1, myThid )
                0136            CALL DIAGNOSTICS_FILL( Shap_tmpFld2, 'SHAP_dV ', 0, Nr,
                0137      &                                           0, 1, 1, myThid )
                0138            diag_dKE = DIAGNOSTICS_IS_ON('SHAP_dKE',myThid)
                0139          ENDIF
                0140 #endif /* ALLOW_DIAGNOSTICS */
                0141 #if ( defined ALLOW_FRICTION_HEATING ) || ( defined ALLOW_DIAGNOSTICS )
                0142          IF ( addFrictionHeating .OR. diag_dKE ) THEN
                0143            DO bj=myByLo(myThid),myByHi(myThid)
                0144             DO bi=myBxLo(myThid),myBxHi(myThid)
                0145              DO k=1,Nr
                0146               DO j=1,sNy
                0147                DO i=1,sNx
                0148                  dKE_shap(i,j) = 0.5 _d 0 *(
73e3454c50 Davi*0149      &             (
                0150      &               Shap_tmpFld1(i  ,j,k,bi,bj)*uFld(i  ,j,k,bi,bj)
                0151      &                *_hFacW(i ,j, k,bi,bj)*rAw(i ,j, bi,bj)
                0152      &              +Shap_tmpFld1(i+1,j,k,bi,bj)*uFld(i+1,j,k,bi,bj)
                0153      &                *_hFacW(i+1,j,k,bi,bj)*rAw(i+1,j,bi,bj)
                0154      &             )
                0155      &           + (
                0156      &               Shap_tmpFld2(i,j  ,k,bi,bj)*vFld(i,j  ,k,bi,bj)
                0157      &                *_hFacS(i,j  ,k,bi,bj)*rAs(i,j  ,bi,bj)
                0158      &              +Shap_tmpFld2(i,j+1,k,bi,bj)*vFld(i,j+1,k,bi,bj)
                0159      &                *_hFacS(i,j+1,k,bi,bj)*rAs(i,j+1,bi,bj)
e24c9bfc82 Jean*0160      &             )                       )*recip_rA(i,j,bi,bj)
73e3454c50 Davi*0161                ENDDO
                0162               ENDDO
8b25254c4a Jean*0163 #ifdef ALLOW_FRICTION_HEATING
                0164               IF ( addFrictionHeating ) THEN
                0165                DO j=1,sNy
                0166                 DO i=1,sNx
                0167                    frictionHeating(i,j,k,bi,bj) =
ed936f6096 Jean*0168      &                             frictionHeating(i,j,k,bi,bj)
                0169      &                           - dKE_shap(i,j)*drF(k)*rUnit2mass
8b25254c4a Jean*0170                 ENDDO
                0171                ENDDO
                0172               ENDIF
                0173 #endif /* ALLOW_FRICTION_HEATING */
                0174 #ifdef ALLOW_DIAGNOSTICS
                0175               IF ( diag_dKE ) THEN
                0176                CALL DIAGNOSTICS_FILL( dKE_shap, 'SHAP_dKE',
                0177      &                                k, 1, 2, bi, bj, myThid )
                0178               ENDIF
64e64319fa Jean*0179 #endif /* ALLOW_DIAGNOSTICS */
8b25254c4a Jean*0180              ENDDO
                0181             ENDDO
                0182            ENDDO
                0183          ENDIF
                0184 #endif /* ALLOW_FRICTION_HEATING or ALLOW_DIAGNOSTICS */
36d530816f Jean*0185         ENDIF
                0186
                0187 #endif /* USE_OLD_SHAPIRO_FILTERS */
                0188
                0189       ENDIF
                0190 #endif /* ALLOW_SHAP_FILT */
                0191
                0192       RETURN
                0193       END