File indexing completed on 2023-02-03 06:10:36 UTC
view on githubraw file Latest commit edb66560 on 2023-02-02 23:32:31 UTC
fc7306ba7d Jean*0001 #include "THSICE_OPTIONS.h"
14de9be26e Jeff*0002 #ifdef ALLOW_ATM2D
0003 # include "ctrparam.h"
0004 #endif
6b47d550f4 Mart*0005 #ifdef ALLOW_AUTODIFF
0006 # include "AUTODIFF_OPTIONS.h"
0007 #endif
87ea84cac6 Jean*0008
0009
fc7306ba7d Jean*0010
0011
17fd302697 Jean*0012 SUBROUTINE THSICE_STEP_FWD(
fc7306ba7d Jean*0013 I bi, bj, iMin, iMax, jMin, jMax,
c8bafbe9ad Jean*0014 I prcAtm, snowPrc, qPrcRnO,
fc7306ba7d Jean*0015 I myTime, myIter, myThid )
87ea84cac6 Jean*0016
fc7306ba7d Jean*0017
17fd302697 Jean*0018
fc7306ba7d Jean*0019
0020
87ea84cac6 Jean*0021
fc7306ba7d Jean*0022
0023
0024 IMPLICIT NONE
87ea84cac6 Jean*0025
fc7306ba7d Jean*0026
0027 #include "SIZE.h"
0028 #include "EEPARAMS.h"
0029 #include "PARAMS.h"
0030 #include "FFIELDS.h"
14de9be26e Jeff*0031 #ifdef ALLOW_ATM2D
0032 # include "ATMSIZE.h"
0033 # include "ATM2D_VARS.h"
0034 #endif
fc7306ba7d Jean*0035 #include "THSICE_SIZE.h"
0036 #include "THSICE_PARAMS.h"
87ea84cac6 Jean*0037 #include "THSICE_VARS.h"
d6f06800ae Patr*0038 #ifdef ALLOW_AUTODIFF_TAMC
0039 # include "tamc.h"
0040 #endif
0041
7269783f6f Jean*0042 INTEGER siLo, siHi, sjLo, sjHi
0043 PARAMETER ( siLo = 1-OLx , siHi = sNx+OLx )
0044 PARAMETER ( sjLo = 1-OLy , sjHi = sNy+OLy )
17fd302697 Jean*0045
fc7306ba7d Jean*0046
0047
7269783f6f Jean*0048
87ea84cac6 Jean*0049
0050
0051
17fd302697 Jean*0052
c8bafbe9ad Jean*0053
bd7be113e1 Jean*0054
7269783f6f Jean*0055
0056
0057
0058
0059
0060
0061
281cce82f4 Jean*0062
87ea84cac6 Jean*0063
7269783f6f Jean*0064
281cce82f4 Jean*0065
fc7306ba7d Jean*0066 INTEGER bi,bj
0067 INTEGER iMin, iMax
0068 INTEGER jMin, jMax
bd7be113e1 Jean*0069 _RL prcAtm (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
c8bafbe9ad Jean*0070 _RL snowPrc(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
bd7be113e1 Jean*0071 _RL qPrcRnO(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
fc7306ba7d Jean*0072 _RL myTime
0073 INTEGER myIter
0074 INTEGER myThid
87ea84cac6 Jean*0075
fc7306ba7d Jean*0076
0077 #ifdef ALLOW_THSICE
0078
0079
7269783f6f Jean*0080
87ea84cac6 Jean*0081
281cce82f4 Jean*0082
0083
0084
87ea84cac6 Jean*0085
7269783f6f Jean*0086
8d92b2862f Jean*0087
7269783f6f Jean*0088
0089
a85293d087 Mart*0090 #ifdef ALLOW_BULK_FORCE
8d92b2862f Jean*0091 LOGICAL isIceFree(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
a85293d087 Mart*0092 #endif
7269783f6f Jean*0093 _RL iceFrac (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0094 _RL flx2oc (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0095 _RL frw2oc (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0096 _RL fsalt (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
281cce82f4 Jean*0097 _RL frzSeaWat(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
7269783f6f Jean*0098 _RL tFrzOce (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0099 _RL frzmltMxL(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0100 _RL ageFac
0101 _RL snowFac
0102 _RL cphm
0103 _RL opFrac, icFrac
0104 INTEGER i,j
0105 LOGICAL dBugFlag
fc7306ba7d Jean*0106
7c50f07931 Mart*0107 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0108
0109 INTEGER tkey
7c50f07931 Mart*0110 #endif
7269783f6f Jean*0111
0112 #include "THSICE_DEBUG.h"
fc7306ba7d Jean*0113
17fd302697 Jean*0114 1010 FORMAT(A,1P4E14.6)
7269783f6f Jean*0115
0116
0117
d6f06800ae Patr*0118 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0119 tkey = bi + (bj-1)*nSx + (ikey_dynamics-1)*nSx*nSy
d6f06800ae Patr*0120 #endif /* ALLOW_AUTODIFF_TAMC */
0121
7269783f6f Jean*0122
ae605e558b Jean*0123 dBugFlag = debugLevel.GE.debLevC
7269783f6f Jean*0124 DO j = 1-OLy, sNy+OLy
1271d2846f Jean*0125 DO i = 1-OLx, sNx+OLx
a85293d087 Mart*0126 #ifdef ALLOW_BULK_FORCE
8d92b2862f Jean*0127 isIceFree(i,j) = .FALSE.
a85293d087 Mart*0128 #endif
14de9be26e Jeff*0129 #ifdef ALLOW_ATM2D
0130 sFluxFromIce(i,j) = 0. _d 0
0131 #else
7269783f6f Jean*0132 saltFlux(i,j,bi,bj) = 0. _d 0
14de9be26e Jeff*0133 #endif
281cce82f4 Jean*0134 frzSeaWat(i,j) = 0. _d 0
6b47d550f4 Mart*0135 #ifdef ALLOW_AUTODIFF
7269783f6f Jean*0136 iceFrac(i,j) = 0.
0707ba3b3d Jean*0137
0138
0139 flx2oc(i,j) = 0. _d 0
0140 frw2oc(i,j) = 0. _d 0
0141 fsalt (i,j) = 0. _d 0
0142
0143
c567874792 Patr*0144 #endif
1271d2846f Jean*0145 ENDDO
7269783f6f Jean*0146 ENDDO
87ea84cac6 Jean*0147
7269783f6f Jean*0148 ageFac = 1. _d 0 - thSIce_deltaT/snowAgTime
0149 snowFac = thSIce_deltaT/(rhos*hNewSnowAge)
77008a74ba Patr*0150
0151 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0152
77008a74ba Patr*0153 #endif
7269783f6f Jean*0154 DO j = jMin, jMax
0155 DO i = iMin, iMax
0156 IF (iceMask(i,j,bi,bj).GT.0. _d 0) THEN
0157
0158 snowAge(i,j,bi,bj) = thSIce_deltaT
0159 & + snowAge(i,j,bi,bj)*ageFac
c8bafbe9ad Jean*0160 IF ( snowPrc(i,j).GT.0. _d 0 )
7269783f6f Jean*0161 & snowAge(i,j,bi,bj) = snowAge(i,j,bi,bj)
c8bafbe9ad Jean*0162 & * EXP( - snowFac*snowPrc(i,j) )
87ea84cac6 Jean*0163
7269783f6f Jean*0164
0165
0166 icFlxAtm(i,j,bi,bj) = icFlxAtm(i,j,bi,bj)
c8bafbe9ad Jean*0167 & - Lfresh*snowPrc(i,j)
bd7be113e1 Jean*0168 & + qPrcRnO(i,j)
7269783f6f Jean*0169
0170 ENDIF
87ea84cac6 Jean*0171 ENDDO
7269783f6f Jean*0172 ENDDO
87ea84cac6 Jean*0173
a4e6fa7055 Jean*0174 #ifdef ALLOW_DIAGNOSTICS
0175 IF ( useDiagnostics ) THEN
668d2abf21 Jean*0176 CALL DIAGNOSTICS_FRACT_FILL( snowPrc,
0177 I iceMask(1-OLx,1-OLy,bi,bj), oneRL, 1,
0178 I 'SIsnwPrc', 0,1,2,bi,bj,myThid )
0179 CALL DIAGNOSTICS_FRACT_FILL( siceAlb, iceMask, oneRL, 1,
0180 I 'SIalbedo', 0,1,1,bi,bj,myThid )
a4e6fa7055 Jean*0181 ENDIF
0182 #endif /* ALLOW_DIAGNOSTICS */
0cef907193 Jean*0183 DO j = jMin, jMax
0184 DO i = iMin, iMax
0185 siceAlb(i,j,bi,bj) = iceMask(i,j,bi,bj)*siceAlb(i,j,bi,bj)
0186 ENDDO
0187 ENDDO
a4e6fa7055 Jean*0188
87ea84cac6 Jean*0189
17fd302697 Jean*0190
0191
87ea84cac6 Jean*0192
0193
fc7306ba7d Jean*0194 DO j = jMin, jMax
0195 DO i = iMin, iMax
87ea84cac6 Jean*0196
7269783f6f Jean*0197 tFrzOce(i,j) = -mu_Tf*sOceMxL(i,j,bi,bj)
87ea84cac6 Jean*0198 cphm = cpwater*rhosw*hOceMxL(i,j,bi,bj)
7269783f6f Jean*0199 frzmltMxL(i,j) = ( tFrzOce(i,j)-tOceMxL(i,j,bi,bj) )
0200 & * cphm/ocean_deltaT
0201 iceFrac(i,j) = iceMask(i,j,bi,bj)
bd7be113e1 Jean*0202 flx2oc(i,j) = icFlxSW(i,j,bi,bj) + qPrcRnO(i,j)
87ea84cac6 Jean*0203
7269783f6f Jean*0204 #ifdef ALLOW_DBUG_THSICE
0205 IF ( dBug(i,j,bi,bj) ) THEN
0206 IF (frzmltMxL(i,j).GT.0. .OR. iceFrac(i,j).GT.0.) THEN
46a14d8906 Jean*0207 WRITE(6,'(A,2I4,2I2)') 'ThSI_FWD: i,j=',i,j,bi,bj
0208 WRITE(6,1010) 'ThSI_FWD:-1- iceMask, hIc, hSn, Tsf =',
7269783f6f Jean*0209 & iceFrac(i,j), iceHeight(i,j,bi,bj),
a83ee9767c Jean*0210 & snowHeight(i,j,bi,bj), Tsrf(i,j,bi,bj)
7269783f6f Jean*0211 WRITE(6,1010) 'ThSI_FWD: ocTs,tFrzOce,frzmltMxL,Qnet=',
0212 & tOceMxL(i,j,bi,bj), tFrzOce(i,j),
0213 & frzmltMxL(i,j), Qnet(i,j,bi,bj)
0214 ENDIF
0215 IF (iceFrac(i,j).GT.0.)
0216 & WRITE(6,1010) 'ThSI_FWD: icFrac,flxAtm,evpAtm,flxSnw=',
0217 & iceFrac(i,j), icFlxAtm(i,j,bi,bj),
c8bafbe9ad Jean*0218 & icFrwAtm(i,j,bi,bj),-Lfresh*snowPrc(i,j)
fc7306ba7d Jean*0219 ENDIF
7269783f6f Jean*0220 #endif
0221 ENDDO
0222 ENDDO
fc7306ba7d Jean*0223
d6f06800ae Patr*0224 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0225
0226
0227
0228
0229
0230
0231
d6f06800ae Patr*0232 #endif
7269783f6f Jean*0233 CALL THSICE_CALC_THICKN(
6dc8890c80 Patr*0234 I bi, bj,
7269783f6f Jean*0235 I iMin,iMax, jMin,jMax, dBugFlag,
0236 I iceMask(siLo,sjLo,bi,bj), tFrzOce,
0237 I tOceMxL(siLo,sjLo,bi,bj), v2ocMxL(siLo,sjLo,bi,bj),
c8bafbe9ad Jean*0238 I snowPrc(siLo,sjLo), prcAtm,
7269783f6f Jean*0239 I sHeating(siLo,sjLo,bi,bj), flxCndBt(siLo,sjLo,bi,bj),
0240 U iceFrac, iceHeight(siLo,sjLo,bi,bj),
0241 U snowHeight(siLo,sjLo,bi,bj), Tsrf(siLo,sjLo,bi,bj),
0242 U Qice1(siLo,sjLo,bi,bj), Qice2(siLo,sjLo,bi,bj),
0243 U icFrwAtm(siLo,sjLo,bi,bj), frzmltMxL, flx2oc,
281cce82f4 Jean*0244 O frw2oc, fsalt, frzSeaWat,
7269783f6f Jean*0245 I myTime, myIter, myThid )
486e9de820 Jean*0246 #ifdef ALLOW_AUTODIFF_TAMC
a85293d087 Mart*0247
0248
edb6656069 Mart*0249
0250
0251
0252
0253
0254
486e9de820 Jean*0255 #endif
a85293d087 Mart*0256
0257
7269783f6f Jean*0258 DO j = jMin, jMax
0259 DO i = iMin, iMax
0260 IF (iceMask(i,j,bi,bj).GT.0. _d 0) THEN
87ea84cac6 Jean*0261
0262 icFrac = iceMask(i,j,bi,bj)
0263 opFrac= 1. _d 0-icFrac
14de9be26e Jeff*0264 #ifdef ALLOW_ATM2D
0265 pass_qnet(i,j) = pass_qnet(i,j) - icFrac*flx2oc(i,j)
0266 pass_evap(i,j) = pass_evap(i,j) - icFrac*frw2oc(i,j)/rhofw
0267 sFluxFromIce(i,j) = -icFrac*fsalt(i,j)
0268 #else
7269783f6f Jean*0269 icFlxAtm(i,j,bi,bj) = icFrac*icFlxAtm(i,j,bi,bj)
0270 & - opFrac*Qnet(i,j,bi,bj)
0271 icFrwAtm(i,j,bi,bj) = icFrac*icFrwAtm(i,j,bi,bj)
6206cdb986 Jean*0272 & + opFrac*EmPmR(i,j,bi,bj)
7269783f6f Jean*0273 Qnet(i,j,bi,bj) = -icFrac*flx2oc(i,j) + opFrac*Qnet(i,j,bi,bj)
6206cdb986 Jean*0274 EmPmR(i,j,bi,bj)= -icFrac*frw2oc(i,j)
7269783f6f Jean*0275 & + opFrac*EmPmR(i,j,bi,bj)
0276 saltFlux(i,j,bi,bj) = -icFrac*fsalt(i,j)
14de9be26e Jeff*0277 #endif
a85293d087 Mart*0278 #if defined(ALLOW_SALT_PLUME) || defined(ALLOW_ATM_COMPON_INTERF)
281cce82f4 Jean*0279
0280
0281
0282 frzSeaWat(i,j) = MAX( -icFrac*frw2oc(i,j), 0. _d 0 )
a85293d087 Mart*0283 #endif
7269783f6f Jean*0284
0285 #ifdef ALLOW_DBUG_THSICE
0286 IF (dBug(i,j,bi,bj)) WRITE(6,1010)
0287 & 'ThSI_FWD:-3- iceFrac, hIc, hSn, Qnet =',
0288 & iceFrac(i,j), iceHeight(i,j,bi,bj),
0289 & snowHeight(i,j,bi,bj), Qnet(i,j,bi,bj)
0290 #endif
fc7306ba7d Jean*0291
6206cdb986 Jean*0292 ELSEIF (hOceMxL(i,j,bi,bj).GT.0. _d 0) THEN
7269783f6f Jean*0293 icFlxAtm(i,j,bi,bj) = -Qnet(i,j,bi,bj)
6206cdb986 Jean*0294 icFrwAtm(i,j,bi,bj) = EmPmR(i,j,bi,bj)
87ea84cac6 Jean*0295 ELSE
7269783f6f Jean*0296 icFlxAtm(i,j,bi,bj) = 0. _d 0
0297 icFrwAtm(i,j,bi,bj) = 0. _d 0
fc7306ba7d Jean*0298 ENDIF
7269783f6f Jean*0299 ENDDO
0300 ENDDO
fc7306ba7d Jean*0301
0302
87ea84cac6 Jean*0303
fc7306ba7d Jean*0304
0305
1271d2846f Jean*0306 DO j = 1-OLy, sNy+OLy
0307 DO i = 1-OLx, sNx+OLx
0308 flx2oc(i,j) = 0. _d 0
0309 frw2oc(i,j) = 0. _d 0
0310 fsalt (i,j) = 0. _d 0
0311 ENDDO
0312 ENDDO
7269783f6f Jean*0313 CALL THSICE_EXTEND(
6dc8890c80 Patr*0314 I bi, bj,
7269783f6f Jean*0315 I iMin,iMax, jMin,jMax, dBugFlag,
0316 I frzmltMxL, tFrzOce,
0317 I tOceMxL(siLo,sjLo,bi,bj),
0318 U iceFrac, iceHeight(siLo,sjLo,bi,bj),
0319 U snowHeight(siLo,sjLo,bi,bj), Tsrf(siLo,sjLo,bi,bj),
0320 U Tice1(siLo,sjLo,bi,bj), Tice2(siLo,sjLo,bi,bj),
0321 U Qice1(siLo,sjLo,bi,bj), Qice2(siLo,sjLo,bi,bj),
0322 O flx2oc, frw2oc, fsalt,
0323 I myTime, myIter, myThid )
87ea84cac6 Jean*0324
77008a74ba Patr*0325 #ifdef ALLOW_AUTODIFF_TAMC
a85293d087 Mart*0326
edb6656069 Mart*0327
0328
0329
0330
77008a74ba Patr*0331 #endif
7269783f6f Jean*0332 DO j = jMin, jMax
0333 DO i = iMin, iMax
ecbcb862f1 Jean*0334
14de9be26e Jeff*0335 #ifdef ALLOW_ATM2D
0336 pass_qnet(i,j) = pass_qnet(i,j) - flx2oc(i,j)
0337 pass_evap(i,j) = pass_evap(i,j) - frw2oc(i,j)/rhofw
0338 sFluxFromIce(i,j)= sFluxFromIce(i,j) - fsalt(i,j)
0339 #else
7269783f6f Jean*0340 Qnet(i,j,bi,bj) = Qnet(i,j,bi,bj) - flx2oc(i,j)
6206cdb986 Jean*0341 EmPmR(i,j,bi,bj)= EmPmR(i,j,bi,bj)- frw2oc(i,j)
7269783f6f Jean*0342 saltFlux(i,j,bi,bj)=saltFlux(i,j,bi,bj) - fsalt(i,j)
14de9be26e Jeff*0343 #endif
a85293d087 Mart*0344 #if defined(ALLOW_SALT_PLUME) || defined(ALLOW_ATM_COMPON_INTERF)
281cce82f4 Jean*0345 frzSeaWat(i,j) = frzSeaWat(i,j) + MAX(-frw2oc(i,j), 0. _d 0 )
a85293d087 Mart*0346 #endif
7269783f6f Jean*0347
0348 #ifdef ALLOW_DBUG_THSICE
ecbcb862f1 Jean*0349 IF (dBug(i,j,bi,bj)) WRITE(6,1010)
7269783f6f Jean*0350 & 'ThSI_FWD:-4- iceFrac, hIc, hSn, Qnet =',
0351 & iceFrac(i,j), iceHeight(i,j,bi,bj),
0352 & snowHeight(i,j,bi,bj), Qnet(i,j,bi,bj)
0353 #endif
fc7306ba7d Jean*0354
a85293d087 Mart*0355 #ifdef ALLOW_BULK_FORCE
8d92b2862f Jean*0356 IF ( hOceMxL(i,j,bi,bj).GT.0. _d 0 )
0357 & isIceFree(i,j) = iceMask(i,j,bi,bj).LE.0. _d 0
a4eca6e929 Jean*0358 & .AND. iceFrac(i,j) .LE.0. _d 0
a85293d087 Mart*0359 #endif
7269783f6f Jean*0360 IF ( iceFrac(i,j) .GT. 0. _d 0 ) THEN
0361 iceMask(i,j,bi,bj)=iceFrac(i,j)
0362 IF ( snowHeight(i,j,bi,bj).EQ.0. _d 0 )
0363 & snowAge(i,j,bi,bj) = 0. _d 0
fc7306ba7d Jean*0364 ELSE
0365 iceMask(i,j,bi,bj) = 0. _d 0
0366 iceHeight(i,j,bi,bj)= 0. _d 0
0367 snowHeight(i,j,bi,bj)=0. _d 0
87ea84cac6 Jean*0368 snowAge(i,j,bi,bj) = 0. _d 0
7269783f6f Jean*0369 Tsrf(i,j,bi,bj) = tOceMxL(i,j,bi,bj)
fc7306ba7d Jean*0370 Tice1(i,j,bi,bj) = 0. _d 0
0371 Tice2(i,j,bi,bj) = 0. _d 0
9d4bfda7d0 Jean*0372 Qice1(i,j,bi,bj) = Lfresh
0373 Qice2(i,j,bi,bj) = Lfresh
fc7306ba7d Jean*0374 ENDIF
77008a74ba Patr*0375 ENDDO
0376 ENDDO
fc7306ba7d Jean*0377
ae89a28819 Jean*0378 #if defined(ALLOW_SALT_PLUME) || defined(ALLOW_ATM_COMPON_INTERF)
0379 IF ( useSALT_PLUME .OR. useCoupler ) THEN
f141670dc2 Jean*0380 CALL THSICE_SALT_PLUME(
1271d2846f Jean*0381 I sOceMxL(1-OLx,1-OLy,bi,bj),
281cce82f4 Jean*0382 I frzSeaWat,
1271d2846f Jean*0383 I iMin,iMax, jMin,jMax, bi, bj,
281cce82f4 Jean*0384 I myTime, myIter, myThid )
f141670dc2 Jean*0385 ENDIF
ae89a28819 Jean*0386 #endif /* ALLOW_SALT_PLUME or ALLOW_ATM_COMPON_INTERF */
f141670dc2 Jean*0387
96502f6244 Jean*0388 IF ( thSIceAdvScheme.LE.0 ) THEN
0389
0390
0391
0392
0393
0394
0395
0396 DO j = jMin, jMax
0397 DO i = iMin, iMax
0398 sIceLoad(i,j,bi,bj) = ( snowHeight(i,j,bi,bj)*rhos
0399 & + iceHeight(i,j,bi,bj)*rhoi
0400 & )*iceMask(i,j,bi,bj)
35780a5bdd Jeff*0401 #ifdef ALLOW_ATM2D
96502f6244 Jean*0402 pass_sIceLoad(i,j)=sIceLoad(i,j,bi,bj)
35780a5bdd Jeff*0403 #endif
96502f6244 Jean*0404 ENDDO
fc7306ba7d Jean*0405 ENDDO
96502f6244 Jean*0406 ENDIF
fc7306ba7d Jean*0407
8d92b2862f Jean*0408 #ifdef ALLOW_BULK_FORCE
0409 IF ( useBulkForce ) THEN
0410 CALL BULKF_FLUX_ADJUST(
0411 I bi, bj, iMin, iMax, jMin, jMax,
0412 I isIceFree, myTime, myIter, myThid )
0413 ENDIF
0414 #endif /* ALLOW_BULK_FORCE */
0415
fc7306ba7d Jean*0416
0417 #endif /* ALLOW_THSICE */
0418
0419 RETURN
0420 END