@@ -50,7 +50,8 @@ SUBROUTINE hailcast_diagnostic_driver ( grid , config_flags &
50
50
51
51
REAL , INTENT (IN ),OPTIONAL :: haildt
52
52
REAL , INTENT (IN ),OPTIONAL :: curr_secs
53
- REAL , INTENT (INOUT ),OPTIONAL :: haildtacttime
53
+ REAL , DIMENSION ( ims:ime, jms:jme ), &
54
+ INTENT (INOUT ),OPTIONAL :: haildtacttime
54
55
INTEGER , INTENT (IN ) :: itimestep
55
56
REAL , INTENT (IN ) :: dt
56
57
@@ -209,10 +210,18 @@ SUBROUTINE hailcast_diagnostic_driver ( grid , config_flags &
209
210
( (.not. grid%nested) .or. &
210
211
( (grid%nested) .and. (abs(grid%dtbc) < 0.0001) ) ) )THEN
211
212
doing_adapt_dt = .TRUE.
212
- IF ( haildtacttime .eq. 0. ) THEN
213
- haildtacttime = CURR_SECS + haildt
214
- END IF
215
- END IF
213
+
214
+ !170519 - bug fix RAS
215
+ !Change haildtacttime to an array so can be set individually
216
+ ! by gridpoint to account for quilted processes
217
+ DO j = j_start, j_end
218
+ DO i = i_start, i_end
219
+ IF ( haildtacttime(i,j) .eq. 0. ) THEN
220
+ haildtacttime(i,j) = CURR_SECS + haildt
221
+ END IF
222
+ ENDDO
223
+ ENDDO
224
+ END IF
216
225
217
226
! Calculate STEPHAIL
218
227
stephail = NINT(haildt / dt)
@@ -270,12 +279,19 @@ SUBROUTINE hailcast_diagnostic_driver ( grid , config_flags &
270
279
decided = .TRUE.
271
280
END IF
272
281
273
- IF ( ( .NOT. decided ) .AND. &
274
- ( doing_adapt_dt ) .AND. &
275
- ( curr_secs .GE. haildtacttime ) ) THEN
276
- run_param = .TRUE.
277
- decided = .TRUE.
278
- haildtacttime = curr_secs + haildt
282
+ !170519 - bug fix RAS
283
+ !Changed haildtacttime to an array so can be set individually
284
+ ! by gridpoint to account for quilted processes
285
+ IF ( ( .NOT. decided ) .AND. &
286
+ ( doing_adapt_dt ) .AND. &
287
+ ( curr_secs .GE. haildtacttime(i_start, j_start) ) ) THEN
288
+ run_param = .TRUE.
289
+ decided = .TRUE.
290
+ DO j = j_start, j_end
291
+ DO i = i_start, i_end
292
+ haildtacttime(i,j) = curr_secs + haildt
293
+ ENDDO
294
+ ENDDO
279
295
END IF
280
296
281
297
write ( message, * ) ' timestep to run HAILCAST? ' , run_param
@@ -442,6 +458,13 @@ END SUBROUTINE hailcast_diagnostic_driver
442
458
!!!! 06 May 2017...................................Becky Adams-Selin AER
443
459
!!!! Bug fixes for some memory issues in the adiabatic liquid
444
460
!!!! water profile code.
461
+ !!!! 23 Apr 2019...................................Becky Adams-Selin AER
462
+ !!!! Added check to make sure embryo spends at least some time in
463
+ !!!! cloud before returning a positive hail diameter.
464
+ !!!! 16 Dec 2022...................................Becky Adams-Selin AER
465
+ !!!! Consolodate a number of bug fixes, including fixing behavior
466
+ !!!! of haildt when tiling is used, and non-SI units errors in
467
+ !!!! HEATBUD subroutine.
445
468
!!!!
446
469
!!!! See Adams-Selin and Ziegler 2016, MWR for further documentation.
447
470
!!!!
@@ -609,7 +632,8 @@ SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,&
609
632
!the difference between the saturation mixing ratio at each level
610
633
!and the cloud base water vapor mixing ratio
611
634
DO k= 1 ,nz
612
- IF (k.LT. KBAS) THEN
635
+ RWA_new(k) = RWA(k)
636
+ IF (k.LT. KBAS) THEN
613
637
RWA_adiabat(k) = 0 .
614
638
CYCLE
615
639
ENDIF
@@ -640,19 +664,10 @@ SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,&
640
664
ELSE IF ((k.ge.KBAS+1).AND.(RWA_adiabat(k).ge.1.E-12)) THEN
641
665
RWA_new(k) = RWA_adiabat(k)*(h1d(k)-h1d(k-1)) - RWA_new(k-1)
642
666
IF (RWA_new(k).LT.0) RWA_new(k) = 0.
643
- ELSE
644
- RWA_new(k) = RWA(k)
645
667
ENDIF
646
- ! - old code - !
647
- !IF (k.eq.KBAS+1) THEN
648
- ! RWA_new(k) = RWA_adiabat(k)*(h1d(k)-h1d(k-1))
649
- !ELSE IF ((k.ge.KBAS+2).AND.(RWA_adiabat(k).ge.1.E-12)) THEN
650
- ! RWA_new(k) = RWA_adiabat(k)*(h1d(k)-h1d(k-1)) - RWA_new(k-1)
651
- ! IF (RWA_new(k).LT.0) RWA_new(k) = 0.
652
- !ENDIF
653
668
ENDDO
654
669
!remove the height factor from RWA_new
655
- DO k=KBAS,nz
670
+ DO k=KBAS+1 ,nz !bug fix, ensure index start 1 higher
656
671
RWA_new(k) = RWA_new(k) / (h1d(k)-h1d(k-1))
657
672
ENDDO
658
673
@@ -696,6 +711,11 @@ SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,&
696
711
CALL INTERP(VUU_pert, VUFZL, WFZLP, IFOUT, PA, nz)
697
712
CALL INTERP(rho1d, DENSAFZL, WFZLP, IFOUT, PA, nz)
698
713
714
+ !Check if height of cloud base is above embryo insertion point
715
+ !RAS-20190423-!
716
+ IF (ZFZL < ZBAS-1000) GOTO 400
717
+
718
+
699
719
!Begin hail simulation time (seconds)
700
720
sec = 0.
701
721
@@ -850,9 +870,15 @@ SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,&
850
870
!so let' s shed any excess water now.
851
871
D_ICE = ( (6 * GM* (1 .- FW)) / (3.141592654 * DENSE) )** 0.33333333
852
872
D = D_ICE
853
- CALL MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
873
+ CALL MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT,TS,DENSE )
854
874
855
875
ENDIF !end check for melting call
876
+
877
+ !RAS - 20190423 - !
878
+ 400 CONTINUE !Check for if embryo insertion point is below cloud base
879
+
880
+ !Require embryo to have stayed aloft for at least some time
881
+ IF (sec.LT. 60 ) D = 0 .
856
882
857
883
!Check to make sure something hasn' t gone horribly wrong
858
884
IF (D.GT.0.254) D = 0. !just consider missing for now if > 10 in
@@ -993,7 +1019,7 @@ SUBROUTINE TERMINL(DENSA,DENSE,D,VT,TC)
993
1019
RE=(GX/0.6)**0.5
994
1020
995
1021
!SELECT APPROPRIATE EQUATIONS FOR TERMINAL VELOCITY DEPENDING ON
996
- !THE BEST NUMBER
1022
+ !THE BEST NUMBER. Follows RH87 pg. 2762, but fixes an error in their (B1).
997
1023
IF (GX.LT.550) THEN
998
1024
W=LOG10(GX)
999
1025
Y= -1.7095 + 1.33438*W - 0.11591*(W**2.0)
@@ -1115,17 +1141,18 @@ SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE,&
1115
1141
!experimentally derived, and are expecting cal-C-g units. Do some conversions.
1116
1142
DENSAC = DENSA * (1.E3) * (1.E-6)
1117
1143
!dynamic viscosity
1118
- ANU=1.717E-4 *(393.0/(TC+120.0))*(TC/273.155)**1.5
1144
+ ANU=1.717E-5 *(393.0/(TC+120.0))*(TC/273.155)**1.5 !RAS units fix to agree with Roger and Yau ps. 102
1119
1145
!!! CALCULATE THE REYNOLDS NUMBER - unitless
1120
1146
RE=D*VT*DENSAC/ANU
1121
1147
E=(0.60)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv)
1122
1148
!!! SELECT APPROPRIATE VALUES OF AE ACCORDING TO RE
1123
1149
IF(RE.LT.6000.0)THEN
1124
1150
AE=0.78+0.308*E
1125
1151
ELSEIF(RE.GE.6000.0.AND.RE.LT.20000.0)THEN
1126
- AE=0.76*E
1152
+ !RAS 190713
1153
+ AE=0.5*0.76*E !bug fix to match RasmussenHeymsfield1987
1127
1154
ELSEIF(RE.GE.20000.0) THEN
1128
- AE= (0.57+9.0E-6*RE)*E
1155
+ AE = 0.5* (0.57+9.0E-6*RE)*E !bug fix to match RasmussenHeymsfield1987
1129
1156
ENDIF
1130
1157
1131
1158
@@ -1159,6 +1186,9 @@ SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE,&
1159
1186
1160
1187
!!! CALCULATE THE TOTAL MASS CHANGE
1161
1188
DGM= DGMW+ DGMI+ DGMV
1189
+ !Dummy arguments in the event of no water, vapor, or ice growth
1190
+ DENSELW = 900 .
1191
+ DENSELI = 700 .
1162
1192
!!! CALCULATE DENSITY OF NEW LAYER, DEPENDS ON FW AND ITYPE
1163
1193
IF (ITYPE.EQ. 1 ) THEN !DRY GROWTH
1164
1194
!If hailstone encountered supercooled water, calculate new layer density
@@ -1169,7 +1199,12 @@ SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE,&
1169
1199
!!! FIND THE STOKES NUMBER (rasmussen heymsfield 1985 )
1170
1200
NS = 2 * VT* 100 .* (DC* 1.E-4 )** 2 . / (9 * ANU* D* 50 ) !need hail radius in cm
1171
1201
!!! FIND IMPACT VELOCITY (rasmussen heymsfield 1985 )
1172
- W = LOG10 (NS)
1202
+ !W = LOG10 (NS) - bug fix 20221216 - RAS !
1203
+ IF (NS.LT. 0.1 )THEN
1204
+ W=- 1 .
1205
+ ELSE
1206
+ W = LOG10 (NS)
1207
+ ENDIF
1173
1208
IF (RE.GT. 200 ) THEN
1174
1209
IF (NS.LT. 0.1 ) THEN
1175
1210
VIMP = 0.0
@@ -1213,7 +1248,7 @@ SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE,&
1213
1248
AFACTOR = - DC* VIMP/ TSCELSIUS
1214
1249
IF ((TSCELSIUS.LE. - 5 .).OR. (AFACTOR.GE. - 1.60 )) THEN
1215
1250
DENSELW = 0.30 * (AFACTOR)** 0.44
1216
- ELSEIF (TSCELSIUS .GT. - 5 .) THEN
1251
+ ELSE
1217
1252
DENSELW = EXP (- 0.03115 - 1.7030 * AFACTOR + &
1218
1253
0.9116 * AFACTOR** 2 . - 0.1224 * AFACTOR** 3 .)
1219
1254
ENDIF
@@ -1309,26 +1344,33 @@ SUBROUTINE HEATBUD(TS,TSm1,TSm2,FW,TC,VT,DELRW,D,DENSA,GM1,GM,DGM,DGMW, &
1309
1344
1310
1345
REAL RV, RD, G, PI, ALF, ALV, ALS, CI, CW, AK
1311
1346
REAL H, AH, TCC, TSC, DELRWC, DENSAC, TDIFF
1347
+ REAL DCM, GMC, DGMWC, DGMIC, GM1C, DGMC
1312
1348
REAL DMLT
1313
1349
REAL TSCm1, TSCm2
1314
1350
DATA RV/461.48/,RD/287.04/,G/9.78956/
1315
1351
DATA PI/3.141592654/,ALF/79.7/,ALV/597.3/
1316
1352
DATA ALS/677.0/,CI/0.5/,CW/1./
1317
1353
1318
- !Convert values to non-SI units here
1354
+ !Convert values to non-SI units here to match all the constants
1319
1355
TSC = TS - 273.155
1320
1356
TSCm1 = TSm1 - 273.155
1321
1357
TSCm2 = TSm2 - 273.155
1322
1358
TCC = TC - 273.155
1323
1359
DELRWC = DELRW * (1.E3) * (1.E-6)
1324
1360
DENSAC = DENSA * (1.E3) * (1.E-6)
1325
1361
!DI still in cm2/sec
1362
+ DCM = D * 100. !m to cm
1363
+ GMC = GM * 1000. !kg to g
1364
+ GM1C = GM1 * 1000. !kg to g
1365
+ DGMWC = DGMW * 1000. !kg to g
1366
+ DGMIC = DGMI * 1000. !kg to g
1367
+ DGMC = DGM * 1000. !kg to g
1326
1368
1327
1369
1328
1370
!!! CALCULATE THE CONSTANTS
1329
1371
AK=(5.8+0.0184*TCC)*1.E-5 !thermal conductivity - cal/(cm*sec*K)
1330
1372
!dynamic viscosity - calculated in MASSAGR
1331
- !ANU=1.717E-4 *(393.0/(TC+120.0))*(TC/273.155)**1.5
1373
+ !ANU=1.717E-5 *(393.0/(TC+120.0))*(TC/273.155)**1.5
1332
1374
1333
1375
!!! CALCULATE THE REYNOLDS NUMBER - unitless
1334
1376
!RE=D*VT*DENSAC/ANU - calculated in MASSAGR
@@ -1341,10 +1383,11 @@ SUBROUTINE HEATBUD(TS,TSm1,TSm2,FW,TC,VT,DELRW,D,DENSA,GM1,GM,DGM,DGMW, &
1341
1383
AH=0.78+0.308*H
1342
1384
!AE=0.78+0.308*E
1343
1385
ELSEIF(RE.GE.6000.0.AND.RE.LT.20000.0)THEN
1344
- AH=0.76*H
1345
- !AE =0.76*E
1386
+ !RAS 190713
1387
+ AH =0.5*0. 76*H !bug fix to match RasmussenHeymsfield1987
1346
1388
ELSEIF(RE.GE.20000.0) THEN
1347
- AH=(0.57+9.0E-6*RE)*H
1389
+ !RAS 190713
1390
+ AH=0.5*(0.57+9.0E-6*RE)*H !bug fix to match RasmussenHeymsfield1987
1348
1391
!AE=(0.57+9.0E-6*RE)*E calculated in MASSAGR
1349
1392
ENDIF
1350
1393
@@ -1358,11 +1401,12 @@ SUBROUTINE HEATBUD(TS,TSm1,TSm2,FW,TC,VT,DELRW,D,DENSA,GM1,GM,DGM,DGMW, &
1358
1401
!TSC=TSC-TSC*DGM/GM1+SEKDEL/(GM1*CI)* &
1359
1402
! (2.*PI*D*(AH*AK*(TCC-TSC)-AE*ALS*DI*DELRWC)+ &
1360
1403
! DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
1361
- TSC=0.6*(TSC-TSC*DGM/GM1+SEKDEL/(GM1*CI)* &
1362
- (2.*PI*D*(AH*AK*(TCC-TSC)-AE*ALS*DI*DELRWC)+ &
1363
- DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)) + &
1404
+ !units fix
1405
+ TSC=0.6*(TSC-TSC*DGMC/GM1C+SEKDEL/(GM1C*CI)* &
1406
+ (2.*PI*DCM*(AH*AK*(TCC-TSC)-AE*ALS*DI*DELRWC)+ &
1407
+ DGMWC/SEKDEL*(ALF+CW*TCC)+DGMIC/SEKDEL*CI*TCC)) + &
1364
1408
0.2*TSCm1 + 0.2*TSCm2
1365
-
1409
+
1366
1410
TS = TSC+273.155
1367
1411
IF (TS.GE.273.155) THEN
1368
1412
TS=273.155
@@ -1375,14 +1419,21 @@ SUBROUTINE HEATBUD(TS,TSm1,TSm2,FW,TC,VT,DELRW,D,DENSA,GM1,GM,DGM,DGMW, &
1375
1419
1376
1420
IF (TCC.LT.0.) THEN
1377
1421
!Original Hailcast algorithm
1378
- FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)* &
1379
- (2.*PI*D*(AH*AK*TCC-AE*ALV*DI*DELRWC)+ &
1380
- DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
1422
+ !FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)* &
1423
+ ! (2.*PI*D*(AH*AK*TCC-AE*ALV*DI*DELRWC)+ &
1424
+ ! DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
1425
+ !units fixed
1426
+ FW = FW-FW*DGMC/GMC+SEKDEL/(GMC*ALF)* &
1427
+ (2.*PI*DCM*(AH*AK*TCC-AE*ALV*DI*DELRWC)+ &
1428
+ DGMWC/SEKDEL*(ALF+CW*TCC)+DGMIC/SEKDEL*CI*TCC)
1381
1429
ELSE
1382
1430
!Calculate decrease in ice mass due to melting
1383
- DMLT = (2.*PI*D*AH*AK*TCC + 2.*PI*D*AE*ALV*DI*DELRWC + &
1384
- DGMW/SEKDEL*CW*TCC) / ALF
1385
- FW = (FW*GM + DMLT) / GM
1431
+ !!Bug fix 28Jul2021 RAS - non-SI units
1432
+ !More non-SI units - fixed 20220307 RAS
1433
+ ! Extra SEKDEL in the calculation - 20221102 RAS
1434
+ DMLT = SEKDEL / ALF * (2.*PI*DCM*AH*AK*TCC + 2.*PI*DCM*AE*ALV*DI*DELRWC + &
1435
+ DGMWC/SEKDEL*CW*TCC)
1436
+ FW = (FW*GM1C + DMLT + DGMWC) / GMC
1386
1437
ENDIF
1387
1438
1388
1439
IF(FW.GT.1.)FW=1.
@@ -1436,13 +1487,19 @@ SUBROUTINE BREAKUP(DENSE,D,GM,FW,CRIT)
1436
1487
END SUBROUTINE BREAKUP
1437
1488
1438
1489
1439
- SUBROUTINE MELT (D ,TLAYER ,PLAYER ,RLAYER ,LDEPTH ,VT )
1490
+ SUBROUTINE MELT (D ,TLAYER ,PLAYER ,RLAYER ,LDEPTH ,VT , TS , DENSE )
1440
1491
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1441
1492
!!! This is a spherical hail melting estimate based on the Goyer
1442
1493
!!! et al. (1969 ) eqn (3 ). The depth of the warm layer, estimated
1443
1494
!!! terminal velocity, and mean temperature of the warm layer are
1444
1495
!!! used. DRB. 11 / 17 / 2003 .
1445
1496
!!!
1497
+ !!! Incorporated some known variables into the subroutine
1498
+ !!! to use instead of constants (VT, TS, DENSE). RAS 10 / 2 / 2019
1499
+ !!!
1500
+ !!! Note - this subroutine assumes melted water is immediately
1501
+ !!! shed. Possibly not the most accurate assumption.
1502
+ !!!
1446
1503
!!! INPUT: TLAYER mean sub- cloud layer temperature (K)
1447
1504
!!! PLAYER mean sub- cloud layer pressure (Pa)
1448
1505
!!! RLAYER mean sub- cloud layer mixing ratio (kg/ kg)
@@ -1453,7 +1510,7 @@ SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
1453
1510
IMPLICIT NONE
1454
1511
1455
1512
REAL * 8 D
1456
- REAL TLAYER, PLAYER, RLAYER, LDEPTH, VT
1513
+ REAL TLAYER, PLAYER, RLAYER, LDEPTH, VT, TS, DENSE
1457
1514
REAL eenv, delta, ewet, de, der, wetold, wetbulb, wetbulbk
1458
1515
REAL tdclayer, tclayer, eps, b, hplayer
1459
1516
REAL * 8 a
@@ -1502,7 +1559,8 @@ SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
1502
1559
dv = 0.25e-4 ! diffusivity of water vapor (m2/ s)
1503
1560
pi = 3.1415927
1504
1561
rv = 1004 . - 287 . ! gas constant for water vapor
1505
- rhoice = 917.0 ! density of ice (kg/ m** 3 )
1562
+ !rhoice = 917.0 ! density of ice (kg/ m** 3 )
1563
+ rhoice = DENSE ! we know the stone density, let' s use it
1506
1564
r = D/2. ! radius of stone (m)
1507
1565
1508
1566
!Compute residence time in warm layer
@@ -1511,12 +1569,14 @@ SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
1511
1569
!Calculate dmdt based on eqn (3) of Goyer et al. (1969)
1512
1570
!Reynolds number...from pg 317 of Atmo Physics (Salby 1996)
1513
1571
!Just use the density of air at 850 mb...close enough.
1514
- rho = 85000 ./ (287 .* TLAYER)
1515
- re = rho* r* VT* .01 / 1.7e-5
1572
+ !rho = 85000./(287.*TLAYER)
1573
+ rho = player/(287.*TLAYER) !we have the layer pressure, just use it
1574
+ !units fix - r is now in meters, not mm. Plus we need D, not r. RAS 20220308
1575
+ re = rho*r*2*VT/1.7e-5
1516
1576
1517
1577
!Temperature difference between environment and hailstone surface
1518
- delt = wetbulb ! - 0.0 !assume stone surface is at 0C
1519
- !wetbulb is in Celsius
1578
+ !We know the stone surface temperature, let ' s use it
1579
+ delt = wetbulb - (TS - 273.155 ) !again, wet bulb is in C
1520
1580
1521
1581
!Difference in vapor density of air stream and equil vapor
1522
1582
!density at the sfc of the hailstone
@@ -1531,7 +1591,7 @@ SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
1531
1591
!Calculate new mass growth
1532
1592
dmdt = (- 1.7 * pi* r* (re** 0.5 )/ lf)* ((ka* delt)+ ((lv- lf)* dv* dsig))
1533
1593
IF (dmdt.gt. 0 .) dmdt = 0
1534
- mass = dmdt* tres
1594
+ mass = dmdt* tres ! < 0
1535
1595
1536
1596
!Find the new hailstone diameter
1537
1597
massorg = 1.33333333 * pi* r* r* r* rhoice
0 commit comments