File indexing completed on 2018-03-02 18:43:51 UTC
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
36d530816f Jean*0001 #include "SHAP_FILT_OPTIONS.h"
0002
d11f474de4 Jean*0003
0004
0005
36d530816f Jean*0006 SUBROUTINE SHAP_FILT_APPLY_UV(
0007 U uFld, vFld,
0008 I myTime, myIter, myThid )
d11f474de4 Jean*0009
0010
0011
0012
8b25254c4a Jean*0013
d11f474de4 Jean*0014
0015
0016
ae409e69d3 Jean*0017
d11f474de4 Jean*0018
36d530816f Jean*0019 IMPLICIT NONE
0020
0021
0022 #include "SIZE.h"
0023 #include "EEPARAMS.h"
0024 #include "PARAMS.h"
d11f474de4 Jean*0025
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
36d530816f Jean*0033
d11f474de4 Jean*0034
0035
0036
0037
0038
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
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
0056
00177dc887 Jean*0057 #ifdef USE_OLD_SHAPIRO_FILTERS
d11f474de4 Jean*0058
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
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
0101
ae409e69d3 Jean*0102
0103
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
0113
0114
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