C $Header: /u/gcmpack/MITgcm/pkg/shap_filt/shap_filt_apply_uv.F,v 1.14 2017/03/24 23:51:14 jmc Exp $ C $Name: $ #include "SHAP_FILT_OPTIONS.h" CBOP C !ROUTINE: SHAP_FILT_APPLY_UV C !INTERFACE: SUBROUTINE SHAP_FILT_APPLY_UV( U uFld, vFld, I myTime, myIter, myThid ) C !DESCRIPTION: \bv C *==========================================================* C | S/R SHAP_FILT_cwAPPLY_UV C | o Apply Shapiro filter on momentum : C | filter the argments uFld & vFld. C *==========================================================* C \ev C !USES: IMPLICIT NONE C == Global variables === #include "SIZE.h" #include "EEPARAMS.h" #include "PARAMS.h" c #include "DYNVARS.h" #include "GRID.h" #include "SHAP_FILT.h" #ifdef ALLOW_FRICTION_HEATING # include "FFIELDS.h" #endif C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == C uFld :: velocity field (U component) on which filter applies C vFld :: velocity field (V component) on which filter applies C myTime :: Current time in simulation C myIter :: Current iteration number in simulation C myThid :: Thread number for this instance of SHAP_FILT_APPLY_UV _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 myIter INTEGER myThid #ifdef ALLOW_SHAP_FILT C !FUNCTIONS: LOGICAL DIFFERENT_MULTIPLE EXTERNAL #ifdef ALLOW_DIAGNOSTICS LOGICAL DIAGNOSTICS_IS_ON EXTERNAL #endif /* ALLOW_DIAGNOSTICS */ C !LOCAL VARIABLES: C == Local variables == #ifdef USE_OLD_SHAPIRO_FILTERS C bi,bj,k :: loop index INTEGER bi, bj, k #else /* USE_OLD_SHAPIRO_FILTERS */ LOGICAL diag_dKE CHARACTER*(10) suff #if ( defined ALLOW_FRICTION_HEATING ) ( defined ALLOW_DIAGNOSTICS ) INTEGER bi, bj, k, i, j _RL dKE_shap(1-OLx:sNx+OLx,1-OLy:sNy+OLy) #endif #endif /* USE_OLD_SHAPIRO_FILTERS */ CEOP IF ( momStepping .AND. nShapUV.GT.0) THEN #ifdef USE_OLD_SHAPIRO_FILTERS _EXCH_XYZ_RL( uFld,myThid ) _EXCH_XYZ_RL( vFld,myThid ) DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) DO k=1, Nr CALL SHAP_FILT_U( uFld,bi,bj,k,myTime,myThid ) CALL SHAP_FILT_V( vFld,bi,bj,k,myTime,myThid ) ENDDO ENDDO ENDDO _EXCH_XYZ_RL( uFld,myThid ) _EXCH_XYZ_RL( vFld,myThid ) #else IF (Shap_funct.EQ.1) THEN CALL SHAP_FILT_UV_S1( U uFld, vFld, Shap_tmpFld1, Shap_tmpFld2, I Nr, myTime, myThid ) ELSEIF (Shap_funct.EQ.2 .OR. Shap_funct.EQ.20) THEN CALL SHAP_FILT_UV_S2( U uFld, vFld, Shap_tmpFld1, Shap_tmpFld2, I Nr, myTime, myThid ) ELSEIF (Shap_funct.EQ.4) THEN CALL SHAP_FILT_UV_S4( U uFld, vFld, Shap_tmpFld1, Shap_tmpFld2, I Nr, myTime, myThid ) c ELSEIF (Shap_funct.EQ.20) THEN c CALL SHAP_FILT_UV_S2G( c U uFld, vFld, Shap_tmpFld1, Shap_tmpFld2, c I Nr, myTime, myThid ) ELSEIF (Shap_funct.EQ.21) THEN CALL SHAP_FILT_UV_S2C( U uFld, vFld, Shap_tmpFld1, Shap_tmpFld2, I Nr, myTime, myThid ) ELSE STOP 'SHAP_FILT_APPLY_UV: Ooops! Bad Shap_funct in UV block' ENDIF C----- Diagnostic of Shapiro Filter effect on Momentum : C Note: Shap_tmpFld1,2 from shap_filt_tracer_s2 (and not s1, s4) C are directly proportional to Delta-U,V due to the Filter IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4 .AND. & DIFFERENT_MULTIPLE(Shap_diagFreq,myTime,deltaTClock) & ) THEN IF ( rwSuffixType.EQ.0 ) THEN WRITE(suff,'(I10.10)') myIter ELSE CALL RW_GET_SUFFIX( suff, myTime, myIter, myThid ) ENDIF CALL WRITE_FLD_XYZ_RL( 'shap_dU.', suff, Shap_tmpFld1, & myIter,myThid) CALL WRITE_FLD_XYZ_RL( 'shap_dV.', suff, Shap_tmpFld2, & myIter,myThid) ENDIF IF ( Shap_funct.NE.1 .AND. Shap_funct.NE.4 .AND. & ( addFrictionHeating .OR. useDiagnostics ) ) THEN diag_dKE = .FALSE. #ifdef ALLOW_DIAGNOSTICS IF ( useDiagnostics ) THEN CALL DIAGNOSTICS_FILL( Shap_tmpFld1, 'SHAP_dU ', 0, Nr, & 0, 1, 1, myThid ) CALL DIAGNOSTICS_FILL( Shap_tmpFld2, 'SHAP_dV ', 0, Nr, & 0, 1, 1, myThid ) diag_dKE = DIAGNOSTICS_IS_ON('SHAP_dKE',myThid) ENDIF #endif /* ALLOW_DIAGNOSTICS */ #if ( defined ALLOW_FRICTION_HEATING ) ( defined ALLOW_DIAGNOSTICS ) IF ( addFrictionHeating .OR. diag_dKE ) 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 dKE_shap(i,j) = 0.5 _d 0 *( & ( & Shap_tmpFld1(i ,j,k,bi,bj)*uFld(i ,j,k,bi,bj) & *_hFacW(i ,j, k,bi,bj)*rAw(i ,j, bi,bj) & +Shap_tmpFld1(i+1,j,k,bi,bj)*uFld(i+1,j,k,bi,bj) & *_hFacW(i+1,j,k,bi,bj)*rAw(i+1,j,bi,bj) & ) & + ( & Shap_tmpFld2(i,j ,k,bi,bj)*vFld(i,j ,k,bi,bj) & *_hFacS(i,j ,k,bi,bj)*rAs(i,j ,bi,bj) & +Shap_tmpFld2(i,j+1,k,bi,bj)*vFld(i,j+1,k,bi,bj) & *_hFacS(i,j+1,k,bi,bj)*rAs(i,j+1,bi,bj) & ) )*recip_rA(i,j,bi,bj) ENDDO ENDDO #ifdef ALLOW_FRICTION_HEATING IF ( addFrictionHeating ) THEN DO j=1,sNy DO i=1,sNx frictionHeating(i,j,k,bi,bj) = & frictionHeating(i,j,k,bi,bj) & - dKE_shap(i,j)*drF(k)*rUnit2mass ENDDO ENDDO ENDIF #endif /* ALLOW_FRICTION_HEATING */ #ifdef ALLOW_DIAGNOSTICS IF ( diag_dKE ) THEN CALL DIAGNOSTICS_FILL( dKE_shap, 'SHAP_dKE', & k, 1, 2, bi, bj, myThid ) ENDIF #endif /* ALLOW_DIAGNOSTICS */ ENDDO ENDDO ENDDO ENDIF #endif /* ALLOW_FRICTION_HEATING or ALLOW_DIAGNOSTICS */ ENDIF #endif /* USE_OLD_SHAPIRO_FILTERS */ ENDIF #endif /* ALLOW_SHAP_FILT */ RETURN END