Line data Source code
1 : !------------------------------------------------------------------------------
2 : ! Harmonized Emissions Component (HEMCO) !
3 : !------------------------------------------------------------------------------
4 : !BOP
5 : !
6 : ! !MODULE: hcox_dust_dead_mod.F
7 : !
8 : ! !DESCRIPTION: Module hcox\_dust\_dead\_mod.F contains routines and
9 : ! variables from Charlie Zender's DEAD dust mobilization model.
10 : ! Most routines are from Charlie Zender, but have been modified and/or
11 : ! cleaned up for inclusion into GEOS-Chem.
12 : !\\
13 : !\\
14 : ! This is a HEMCO extension module that uses many of the HEMCO core
15 : ! utilities.
16 : !\\
17 : !\\
18 : ! NOTE: The current (dust) code was validated at 2 x 2.5 resolution.
19 : ! We have found that running at 4x5 we get much lower (~50%) dust
20 : ! emissions than at 2x2.5. Recommend we either find a way to scale
21 : ! the U* computed in the dust module, or run a 1x1 and store the the
22 : ! dust emissions, with which to drive lower resolution runs.
23 : ! -- Duncan Fairlie, 1/25/07
24 : !\\
25 : !\\
26 : ! (We'll) implement the [dust] code in the standard [GEOS-Chem]
27 : ! model and put a warning about expected low bias when the simulation
28 : ! is run at 4x5. Whoever is interested in running dust at 4x5 in the
29 : ! future can deal with making the fix.
30 : ! -- Daniel Jacob, 1/25/07
31 : !\\
32 : !\\
33 : ! !REFERENCES:
34 : !
35 : ! \begin{itemize}
36 : ! \item Zender, C. S., Bian, H., and Newman, D.: Mineral Dust Entrainment and
37 : ! Deposition (DEAD) model: Description and 1990s dust climatology,
38 : ! Journal of Geophysical Research: Atmospheres, 108, 2003.
39 : ! \end{itemize}
40 : !
41 : ! !INTERFACE:
42 : !
43 : MODULE HCOX_DUSTDEAD_MOD
44 : !
45 : ! !USES:
46 : !
47 : USE HCO_ERROR_MOD
48 : USE HCO_DIAGN_MOD
49 : USE HCOX_State_MOD, ONLY : Ext_State
50 : USE HCO_STATE_MOD, ONLY : HCO_State
51 :
52 : IMPLICIT NONE
53 : PRIVATE
54 : !
55 : ! !PUBLIC MEMBER FUNCTIONS:
56 : !
57 : PUBLIC :: HCOX_DustDead_Run
58 : PUBLIC :: HCOX_DustDead_Init
59 : PUBLIC :: HCOX_DustDead_Final
60 : !
61 : ! !REVISION HISTORY:
62 : ! 08 Apr 2004 - T. D. Fairlie - Initial version
63 : ! See https://github.com/geoschem/hemco for complete history
64 : !EOP
65 : !------------------------------------------------------------------------------
66 : !BOC
67 : !
68 : ! !MODULE VARIABLES:
69 : !
70 : ! Now pack all local variables into customized instance
71 : TYPE :: MyInst
72 :
73 : ! Fields required by module
74 : INTEGER :: Instance
75 : INTEGER :: ExtNr ! Extension num for DustDead
76 : INTEGER :: ExtNrAlk ! Extension num for DustAlk
77 : INTEGER, ALLOCATABLE :: HcoIDs(:) ! tracer IDs for DustDead
78 : INTEGER, ALLOCATABLE :: HcoIDsAlk(:) ! tracer IDs for DustAlk
79 : REAL*8 :: FLX_MSS_FDG_FCT
80 :
81 : !---------------------------------------
82 : ! 2-D pointers pointing to netCDF arrays
83 : !---------------------------------------
84 :
85 : ! Time-invariant fields
86 : REAL(hp), POINTER :: ERD_FCT_GEO (:,:) => NULL()
87 : ! REAL, POINTER :: ERD_FCT_HYDRO(:,:,:,:)
88 : ! REAL, POINTER :: ERD_FCT_TOPO (:,:,:,:)
89 : ! REAL, POINTER :: ERD_FCT_UNITY(:,:,:,:)
90 : ! REAL, POINTER :: MBL_BSN_FCT (:,:,:,:)
91 :
92 : ! GOCART source function (tdf, bmy, 1/25/07)
93 : REAL(hp), POINTER :: SRCE_FUNC(:,:) => NULL()
94 :
95 : ! Land surface that is not lake or wetland (by area)
96 : REAL(hp), POINTER :: LND_FRC_DRY (:,:) => NULL()
97 : REAL(hp), POINTER :: MSS_FRC_CACO3(:,:) => NULL()
98 : REAL(hp), POINTER :: MSS_FRC_CLY (:,:) => NULL()
99 : REAL(hp), POINTER :: MSS_FRC_SND (:,:) => NULL()
100 : REAL(hp), POINTER :: SFC_TYP (:,:) => NULL()
101 : REAL(hp), POINTER :: VAI_DST(:,:) => NULL()
102 :
103 : ! Time-varying surface info from CTM
104 : ! REAL*8, ALLOCATABLE :: FLX_LW_DWN_SFC(:,:)
105 : ! REAL*8, ALLOCATABLE :: FLX_SW_ABS_SFC(:,:)
106 : ! REAL*8, ALLOCATABLE :: TPT_GND(:,:)
107 : ! REAL*8, ALLOCATABLE :: TPT_SOI(:,:)
108 : ! REAL*8, ALLOCATABLE :: VWC_SFC(:,:)
109 :
110 : ! Variables initialized in dst_tvbds_ntp() and dst_tvbds_ini()
111 : ! REAL*8, ALLOCATABLE :: SRC_STR(:,:)
112 :
113 : ! LSM plant type, 28 land surface types plus 0 for ocean
114 : ! Also account for 3 different land types in each grid box
115 : ! NN_SFCTYP denotes the highest possible surface type number.
116 : ! (ckeller, 07/24/2014)
117 : INTEGER, ALLOCATABLE :: PLN_TYP(:,:)
118 : REAL*8, ALLOCATABLE :: PLN_FRC(:,:)
119 : REAL*8, ALLOCATABLE :: TAI(:,:)
120 :
121 : ! Other fields
122 : REAL*8, ALLOCATABLE :: DMT_VWR(:)
123 : ! REAL*8, ALLOCATABLE :: DNS_AER(:)
124 : REAL*8, ALLOCATABLE :: OVR_SRC_SNK_FRC(:,:)
125 : REAL*8, ALLOCATABLE :: OVR_SRC_SNK_MSS(:,:)
126 : ! INTEGER, ALLOCATABLE :: OROGRAPHY(:,:)
127 : REAL*8, ALLOCATABLE :: DMT_MIN(:)
128 : REAL*8, ALLOCATABLE :: DMT_MAX(:)
129 : REAL*8, ALLOCATABLE :: DMT_VMA_SRC(:)
130 : REAL*8, ALLOCATABLE :: GSD_ANL_SRC(:)
131 : REAL*8, ALLOCATABLE :: MSS_FRC_SRC(:)
132 : TYPE(MyInst), POINTER :: NextInst => NULL()
133 : END TYPE MyInst
134 :
135 : ! Pointer to instances
136 : TYPE(MyInst), POINTER :: AllInst => NULL()
137 :
138 : !---------------------------------------
139 : ! MODULE PARAMETER
140 : !---------------------------------------
141 : INTEGER, PARAMETER :: NBINS = 4 ! # of dust bins
142 : INTEGER, PARAMETER :: NN_SFCTYP = 28
143 :
144 : ! Fundamental physical constants
145 : REAL*8, PARAMETER :: GAS_CST_UNV = 8.3144598d0
146 : REAL*8, PARAMETER :: MMW_H2O = 1.8015259d-02
147 : REAL*8, PARAMETER :: MMW_DRY_AIR = 28.97d-3
148 : REAL*8, PARAMETER :: CST_VON_KRM = 0.4d0
149 : REAL*8, PARAMETER :: GRV_SFC = 9.80665d0
150 : REAL*8, PARAMETER :: GAS_CST_DRY_AIR = 287.0d0
151 : REAL*8, PARAMETER :: RDS_EARTH = 6.37122d+6
152 : REAL*8, PARAMETER :: GAS_CST_H2O = 461.65D0
153 : REAL*8, PARAMETER :: SPC_HEAT_DRY_AIR = 1005.0d0
154 : REAL*8, PARAMETER :: TPT_FRZ_PNT = 273.15d0
155 :
156 : ! Derived quantities
157 : REAL*8, PARAMETER :: GRV_SFC_RCP = 1.0d0 / GRV_SFC
158 : REAL*8, PARAMETER :: CST_VON_KRM_RCP = 1.0d0 / CST_VON_KRM
159 : REAL*8, PARAMETER :: EPS_H2O = MMW_H2O / MMW_DRY_AIR
160 : REAL*8, PARAMETER :: EPS_H2O_RCP_M1 = -1.0d0 + MMW_DRY_AIR
161 : & / MMW_H2O
162 : REAL*8, PARAMETER :: KAPPA_DRY_AIR = GAS_CST_DRY_AIR
163 : & / SPC_HEAT_DRY_AIR
164 :
165 : ! Fixed-size grid information
166 : INTEGER, PARAMETER :: DST_SRC_NBR = 3
167 : INTEGER, PARAMETER :: MVT = 14
168 :
169 : CONTAINS
170 : !EOC
171 : !------------------------------------------------------------------------------
172 : ! Harmonized Emissions Component (HEMCO) !
173 : !------------------------------------------------------------------------------
174 : !BOP
175 : !
176 : ! !IROUTINE: HCOX_DustDead_Run
177 : !
178 : ! !DESCRIPTION: Subroutine HcoX\_DustDead\_Run is the driver routine
179 : ! for the HEMCO DEAD dust extension.
180 : !\\
181 : !\\
182 : ! !INTERFACE:
183 : !
184 0 : SUBROUTINE HCOX_DustDead_Run( ExtState, HcoState, RC )
185 : !
186 : ! !USES:
187 : !
188 : USE HCO_CALC_MOD, ONLY : HCO_EvalFld, HCO_CalcEmis
189 : USE HCO_FLUXARR_MOD, ONLY : HCO_EmisAdd
190 : USE HCO_CLOCK_MOD, ONLY : HcoClock_Get
191 : USE HCO_CLOCK_MOD, ONLY : HcoClock_First
192 : !
193 : ! !INPUT PARAMETERS:
194 : !
195 : TYPE(Ext_State), POINTER :: ExtState ! Module options
196 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
197 : !
198 : ! !INPUT/OUTPUT PARAMETERS:
199 : !
200 : INTEGER, INTENT(INOUT) :: RC
201 :
202 : ! !REVISION HISTORY:
203 : ! 08 Apr 2004 - T. D. Fairlie - Initial version
204 : ! See https://github.com/geoschem/hemco for complete history
205 : !EOP
206 : !------------------------------------------------------------------------------
207 : !BOC
208 : !
209 : ! !LOCAL VARIABLES:
210 : !
211 : ! Scalars
212 : LOGICAL :: ERR
213 : INTEGER :: I, J, L, N
214 : INTEGER :: M, IOS, INC, LAT_IDX
215 : INTEGER :: NDB, NSTEP, intDOY
216 : REAL*8 :: W10M, DEN, DIAM, U_TS0
217 : REAL*8 :: U_TS, SRCE_P, Reynol, YMID_R
218 : REAL*8 :: ALPHA, BETA, GAMMA, CW
219 : REAL*8 :: XTAU, P1, P2
220 : REAL*8 :: AREA_M2, DTSRCE, DOY
221 :
222 : ! Arrays
223 0 : INTEGER :: OROGRAPHY(HcoState%NX,HcoState%NY)
224 : REAL*8 :: PSLON(HcoState%NX) ! surface pressure
225 0 : REAL*8 :: PTHICK(HcoState%NX) ! delta P (L=1)
226 0 : REAL*8 :: PMID(HcoState%NX) ! mid layer P (L=1)
227 0 : REAL*8 :: TLON(HcoState%NX) ! temperature (L=1)
228 0 : REAL*8 :: THLON(HcoState%NX) ! pot. temp. (L=1)
229 0 : REAL*8 :: ULON(HcoState%NX) ! U-wind (L=1)
230 0 : REAL*8 :: VLON(HcoState%NX) ! V-wind (L=1)
231 0 : REAL*8 :: BHT2(HcoState%NX) ! half box height (L=1)
232 0 : REAL*8 :: Q_H2O(HcoState%NX) ! specific humidity (L=1)
233 0 : REAL*8 :: ORO(HcoState%NX) ! "orography"
234 0 : REAL*8 :: SNW_HGT_LQD(HcoState%NX) ! equivalent snow ht.
235 0 : REAL*8 :: DSRC(HcoState%NX,NBINS) ! dust mixing ratio incr.
236 0 : REAL*8 :: DUST_EMI_TOTAL(HcoState%NX) ! total dust emiss
237 :
238 : ! Flux array [kg/m2/s]
239 : REAL(hp), TARGET :: FLUX(HcoState%NX,
240 : & HcoState%NY,
241 0 : & NBINS)
242 :
243 : ! Flux array for dust alkalinity [kg/m2/s]
244 : REAL(hp), TARGET :: FLUX_ALK(HcoState%NX,
245 : & HcoState%NY,
246 0 : & NBINS)
247 :
248 : ! Pointers
249 : TYPE(MyInst), POINTER :: Inst
250 :
251 : ! Strings
252 : CHARACTER(LEN=255) :: MSG, LOC
253 : !
254 : ! !DEFINED PARAMETERS:
255 : !
256 : ! REAL*8, PARAMETER :: Ch_dust = 9.375d-10
257 : ! REAL*8, PARAMETER :: g0 = 9.80665d0
258 : ! REAL*8, PARAMETER :: G = g0 * 1.D2
259 : ! REAL*8, PARAMETER :: RHOA = 1.25D-3
260 : REAL*8, PARAMETER :: CP = 1004.16d0
261 : REAL*8, PARAMETER :: RGAS = 8314.3d0 / 28.97d0
262 : REAL*8, PARAMETER :: AKAP = RGAS / CP
263 : REAL*8, PARAMETER :: P1000 = 1000d0
264 :
265 : !=================================================================
266 : ! HCOX_DUSTDEAD_RUN begins here!
267 : !=================================================================
268 0 : LOC = 'HCOX_DUSTDEAD_RUN (HCOX_DUSTDEAD_MOD.F)'
269 :
270 : ! Return if extension disabled
271 0 : IF ( ExtState%DustDead <= 0 ) RETURN
272 :
273 : ! Enter
274 0 : CALL HCO_ENTER( HcoState%Config%Err, LOC, RC )
275 0 : IF ( RC /= HCO_SUCCESS ) THEN
276 0 : CALL HCO_ERROR( 'ERROR 0', RC, THISLOC=LOC )
277 0 : RETURN
278 : ENDIF
279 :
280 : ! Get instance
281 0 : Inst => NULL()
282 0 : CALL InstGet ( ExtState%DustDead, Inst, RC )
283 0 : IF ( RC /= HCO_SUCCESS ) THEN
284 0 : WRITE(MSG,*) 'Cannot find DEAD instance Nr. ', ExtState%DustDead
285 0 : CALL HCO_ERROR(MSG,RC)
286 0 : RETURN
287 : ENDIF
288 :
289 : !=================================================================
290 : ! Get pointers to gridded data imported through config. file
291 : !=================================================================
292 : !
293 : ! The following time-invariant fields are read in
294 : ! ERD_FCT_GEO ; geomorphic erodibility: HcoState%NX HcoState%NY
295 : ! ERD_FCT_HYDRO ; hydrologic erodibility: HcoState%NX HcoState%NY
296 : ! ERD_FCT_TOPO ; topog. erodibility (Ginoux): HcoState%NX HcoState%NY
297 : ! ERD_FCT_UNITY ; uniform erodibility: HcoState%NX HcoState%NY
298 : ! MBL_BSN_FCT ; overall erodibility factor : HcoState%NX HcoState%NY
299 : !
300 : ! Erodibility field should be copied onto mbl_bsn_fct
301 : ! which is the one used by the DEAD code Duncan 8/1/2003
302 : !
303 : ! LND_FRC_DRY ; dry land fraction: HcoState%NX HcoState%NY
304 : ! MSS_FRC_CACO3 ; mass fraction of soil CaCO3: HcoState%NX HcoState%NY
305 : ! MSS_FRC_CLY ; mass fraction of clay: HcoState%NX HcoState%NY
306 : ! MSS_FRC_SND ; mass fraction of sand: HcoState%NX HcoState%NY
307 : ! SFC_TYP ; surface type: HcoState%NX HcoState%NY
308 : !=================================================================
309 : !IF ( HcoClock_First(HcoState%Clock,.TRUE.) ) THEN
310 : CALL HCO_EvalFld( HcoState, 'DEAD_EF_GEO',
311 0 : & Inst%ERD_FCT_GEO, RC)
312 0 : IF ( RC /= HCO_SUCCESS ) THEN
313 0 : CALL HCO_ERROR( 'ERROR 1', RC, THISLOC=LOC )
314 0 : RETURN
315 : ENDIF
316 :
317 : CALL HCO_EvalFld( HcoState, 'DEAD_LF_DRY',
318 0 : & Inst%LND_FRC_DRY, RC)
319 0 : IF ( RC /= HCO_SUCCESS ) THEN
320 0 : CALL HCO_ERROR( 'ERROR 2', RC, THISLOC=LOC )
321 0 : RETURN
322 : ENDIF
323 :
324 : CALL HCO_EvalFld( HcoState, 'DEAD_MF_CACO3',
325 0 : & Inst%MSS_FRC_CACO3, RC )
326 0 : IF ( RC /= HCO_SUCCESS ) THEN
327 0 : CALL HCO_ERROR( 'ERROR 3', RC, THISLOC=LOC )
328 0 : RETURN
329 : ENDIF
330 :
331 : CALL HCO_EvalFld( HcoState, 'DEAD_MF_CLY',
332 0 : & Inst%MSS_FRC_CLY, RC)
333 0 : IF ( RC /= HCO_SUCCESS ) THEN
334 0 : CALL HCO_ERROR( 'ERROR 4', RC, THISLOC=LOC )
335 0 : RETURN
336 : ENDIF
337 :
338 : CALL HCO_EvalFld( HcoState, 'DEAD_MF_SND',
339 0 : & Inst%MSS_FRC_SND, RC)
340 0 : IF ( RC /= HCO_SUCCESS ) THEN
341 0 : CALL HCO_ERROR( 'ERROR 5', RC, THISLOC=LOC )
342 0 : RETURN
343 : ENDIF
344 :
345 : CALL HCO_EvalFld( HcoState, 'DEAD_SFC_TYP',
346 0 : & Inst%SFC_TYP, RC )
347 0 : IF ( RC /= HCO_SUCCESS ) THEN
348 0 : CALL HCO_ERROR( 'ERROR 6', RC, THISLOC=LOC )
349 0 : RETURN
350 : ENDIF
351 :
352 : CALL HCO_EvalFld( HcoState, 'DEAD_GOC_SRC',
353 0 : & Inst%SRCE_FUNC, RC )
354 0 : IF ( RC /= HCO_SUCCESS ) THEN
355 0 : CALL HCO_ERROR( 'ERROR 7', RC, THISLOC=LOC )
356 0 : RETURN
357 : ENDIF
358 :
359 : CALL HCO_EvalFld( HcoState, 'DEAD_VAI',
360 0 : & Inst%VAI_DST, RC )
361 0 : IF ( RC /= HCO_SUCCESS ) THEN
362 0 : CALL HCO_ERROR( 'ERROR 8', RC, THISLOC=LOC )
363 0 : RETURN
364 : ENDIF
365 :
366 : ! FIRST = .FALSE.
367 : !ENDIF
368 :
369 : !=================================================================
370 : ! CALL DUST MOBILIZATION SCHEME
371 : !=================================================================
372 :
373 : ! Make OROGRAPHY array (0=Ocean; 1=Land; 2=Ice)
374 0 : CALL GET_ORO( HcoState, ExtState, OROGRAPHY, RC )
375 0 : IF ( RC /= HCO_SUCCESS ) THEN
376 0 : CALL HCO_ERROR( 'ERROR 9', RC, THISLOC=LOC )
377 0 : RETURN
378 : ENDIF
379 :
380 : ! Get emissions time step
381 0 : DTSRCE = HcoState%TS_EMIS
382 :
383 : ! Get day of year, convert to real!!
384 0 : CALL HcoClock_Get( HcoState%Clock, cDOY = intDOY, RC=RC )
385 0 : IF ( RC /= HCO_SUCCESS ) THEN
386 0 : CALL HCO_ERROR( 'ERROR 10', RC, THISLOC=LOC )
387 0 : RETURN
388 : ENDIF
389 0 : DOY = intDOY
390 :
391 : ! Init
392 0 : FLUX(:,:,:) = 0.0_hp
393 0 : FLUX_ALK(:,:,:) = 0.0_hp
394 :
395 : ! Error check
396 0 : ERR = .FALSE.
397 :
398 : !$OMP PARALLEL DO
399 : !$OMP+DEFAULT( SHARED )
400 : !$OMP+PRIVATE( I, J, P1, P2, PTHICK, PMID, TLON )
401 : !$OMP+PRIVATE( THLON, ULON, VLON, BHT2, Q_H2O, ORO, SNW_HGT_LQD )
402 : !$OMP+PRIVATE( N, YMID_R, DSRC, RC, AREA_M2, DUST_EMI_TOTAL )
403 :
404 : ! Loop over latitudes
405 0 : DO J = 1, HcoState%NY
406 :
407 : ! Don't do calculations if there has been an error
408 0 : IF ( ERR ) CYCLE
409 :
410 : ! Loop over longitudes
411 0 : DO I = 1, HcoState%NX
412 :
413 : ! Pressure [Pa] at bottom and top edge of level 1
414 0 : P1 = HcoState%Grid%PEDGE%Val(I,J,1)
415 0 : P2 = HcoState%Grid%PEDGE%Val(I,J,2)
416 :
417 : ! Pressure thickness of 1st layer [Pa]
418 0 : PTHICK(I) = ( P1 - P2 )
419 :
420 : ! Pressure at midpt of surface layer [Pa]
421 0 : PMID(I) = ( P1 + P2 ) / 2.0_hp
422 :
423 : ! Temperature [K] at midpoint of surface layer
424 0 : TLON(I) = ExtState%TK%Arr%Val(I,J,1)
425 :
426 : ! Potential temperature [K] at midpoint
427 0 : THLON(I) = TLON(I) * ( P1000 / PMID(I) )**AKAP
428 :
429 : ! U and V winds at surface [m/s]
430 : ! --> These variables won't be used at all...
431 0 : ULON(I) = ExtState%U10M%Arr%Val(I,J)
432 0 : VLON(I) = ExtState%V10M%Arr%Val(I,J)
433 :
434 : ! Half box height at surface [m]
435 0 : BHT2(I) = HcoState%Grid%BXHEIGHT_M%Val(I,J,1) / 2.d0
436 :
437 : ! Specific humidity at midpoint of surface layer [kg H2O/kg air]
438 0 : Q_H2O(I) = ExtState%SPHU%Arr%Val(I,J,1)
439 :
440 : ! Orography at surface
441 : ! Ocean is 0; land is 1; ice is 2
442 0 : ORO(I) = REAL(OROGRAPHY(I,J),KIND=dp)
443 :
444 : ! Snow [m H2O]. SNOWHGT is in kg H2O/m2, which is equivalent to
445 : ! mm H2O. Convert to m H2O here.
446 0 : SNW_HGT_LQD(I) = ExtState%SNOWHGT%Arr%Val(I,J) / 1000.d0
447 :
448 : ! Dust tracer and increments
449 0 : DSRC(I,:) = 0.0d0
450 : ENDDO !I
451 :
452 : !==============================================================
453 : ! CALL DUST MOBILIZATION DRIVER (DST_MBL) FOR LATITUDE J
454 : !==============================================================
455 :
456 : ! Latitude in RADIANS
457 0 : YMID_R = HcoState%Grid%YMID%Val(1,J) * HcoState%Phys%PI /180.d0
458 :
459 : ! Call DEAD dust mobilization
460 : CALL DST_MBL( HcoState, ExtState, Inst, DOY,
461 : & BHT2, J, YMID_R, ORO,
462 : & PTHICK, PMID, Q_H2O, DSRC, SNW_HGT_LQD,
463 : & DTSRCE, TLON, THLON, VLON, ULON,
464 0 : & J, RC )
465 :
466 : ! Error check
467 0 : IF ( RC /= HCO_SUCCESS ) THEN
468 : ERR = .TRUE.
469 : CYCLE
470 : ENDIF
471 :
472 : ! Redistribute dust emissions using new dust size distribution
473 : ! scheme (L. Zhang, 6/26/15)
474 0 : DUST_EMI_TOTAL = 0.0d0
475 0 : DO N = 1, NBINS
476 0 : DUST_EMI_TOTAL(:) = DUST_EMI_TOTAL(:) + DSRC(:,N)
477 : ENDDO
478 0 : DSRC(:,1) = DUST_EMI_TOTAL(:) * 0.0766d0
479 0 : DSRC(:,2) = DUST_EMI_TOTAL(:) * 0.1924d0
480 0 : DSRC(:,3) = DUST_EMI_TOTAL(:) * 0.3491d0
481 0 : DSRC(:,4) = DUST_EMI_TOTAL(:) * 0.3819d0
482 :
483 : ! Write to emissions array
484 0 : DO I = 1, HcoState%NX
485 :
486 : ! Loop over dust tracers
487 : ! Write into flux array: kg/box --> kg/m2/s
488 0 : AREA_M2 = HcoState%Grid%AREA_M2%Val( I, J )
489 0 : DO N = 1, NBINS
490 :
491 0 : IF ( Inst%HcoIDs(N) > 0 ) THEN
492 0 : FLUX(I,J,N) = ( DSRC(I,N) / AREA_M2 / DTSRCE )
493 : ENDIF
494 :
495 : ! Include DUST Alkalinity SOURCE, assuming an alkalinity
496 : ! of 4% by weight [kg]. !tdf 05/10/08
497 : !tdf with 3% Ca, there's also 1% equ. Mg, makes 4%
498 0 : IF ( Inst%ExtNrAlk > 0 ) THEN
499 0 : FLUX_ALK(I,J,N) = 0.04 * ( DSRC(I,N) / AREA_M2 /
500 0 : & DTSRCE )
501 : ENDIF
502 :
503 : ENDDO !N
504 : ENDDO !I
505 : ENDDO !J
506 : !$OMP END PARALLEL DO
507 :
508 : ! Error check
509 0 : IF ( ERR ) THEN
510 0 : RC = HCO_FAIL
511 0 : RETURN
512 : ENDIF
513 :
514 : !=================================================================
515 : ! PASS TO HEMCO STATE AND UPDATE DIAGNOSTICS
516 : !=================================================================
517 0 : DO N = 1, NBINS
518 :
519 0 : IF ( Inst%HcoIDs(N) > 0 ) THEN
520 :
521 : ! Add to emissions array
522 : CALL HCO_EmisAdd( HcoState, FLUX(:,:,N),
523 0 : & Inst%HcoIDs(N), RC, ExtNr=Inst%ExtNr )
524 0 : IF ( RC /= HCO_SUCCESS ) THEN
525 0 : WRITE(MSG,*) 'HCO_EmisAdd error: dust bin ', N
526 0 : CALL HCO_ERROR(MSG, RC )
527 0 : RETURN
528 : ENDIF
529 :
530 : ENDIF
531 :
532 0 : IF ( Inst%ExtNrAlk > 0 ) THEN
533 0 : IF ( Inst%HcoIDsAlk(N) > 0 ) THEN
534 :
535 : ! Add to dust alkalinity emissions array
536 : CALL HCO_EmisAdd( HcoState, FLUX_Alk(:,:,N),
537 : & Inst%HcoIDsAlk(N), RC,
538 0 : & ExtNr=Inst%ExtNrAlk )
539 0 : IF ( RC /= HCO_SUCCESS ) THEN
540 0 : WRITE(MSG,*) 'HCO_EmisAdd error: dust alk bin ', N
541 0 : CALL HCO_ERROR(MSG, RC )
542 0 : RETURN
543 : ENDIF
544 :
545 : ENDIF
546 : ENDIF
547 :
548 : ENDDO !N
549 :
550 : ! Return w/ success
551 0 : Inst => NULL()
552 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
553 :
554 : END SUBROUTINE HCOX_DustDead_Run
555 : !EOC
556 : !------------------------------------------------------------------------------
557 : ! Harmonized Emissions Component (HEMCO) !
558 : !------------------------------------------------------------------------------
559 : !BOP
560 : !
561 : ! !IROUTINE: HCOX_DustDead_Init
562 : !
563 : ! !DESCRIPTION: Subroutine HcoX\_DustDead\_Init initializes the HEMCO
564 : ! DUST\_DEAD extension.
565 : !\\
566 : !\\
567 : ! !INTERFACE:
568 : !
569 0 : SUBROUTINE HCOX_DustDead_Init ( HcoState, ExtName,
570 : & ExtState, RC )
571 : !
572 : ! !USES:
573 : !
574 : USE HCO_ExtList_Mod, ONLY : GetExtNr, GetExtOpt
575 : USE HCO_STATE_MOD, ONLY : HCO_GetExtHcoID
576 : !
577 : ! !INPUT PARAMETERS:
578 : !
579 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
580 : CHARACTER(LEN=*), INTENT(IN ) :: ExtName ! Extension name
581 : TYPE(Ext_State), POINTER :: ExtState ! Module options
582 : !
583 : ! !INPUT/OUTPUT PARAMETERS:
584 : !
585 : INTEGER, INTENT(INOUT) :: RC
586 :
587 : ! !REVISION HISTORY:
588 : ! 25 Nov 2013 - C. Keller - Now a HEMCO extension
589 : ! See https://github.com/geoschem/hemco for complete history
590 : !EOP
591 : !------------------------------------------------------------------------------
592 : !BOC
593 : !
594 : ! !LOCAL VARIABLES:
595 : !
596 : CHARACTER(LEN=255) :: MSG, LOC
597 : INTEGER :: I, J, N, AS
598 : INTEGER :: ExtNr, nSpc
599 : INTEGER :: nSpcAlk
600 0 : CHARACTER(LEN=31), ALLOCATABLE :: SpcNames(:)
601 0 : CHARACTER(LEN=31), ALLOCATABLE :: SpcNamesAlk(:)
602 : REAL(dp) :: TmpScal
603 : LOGICAL :: FOUND
604 : TYPE(MyInst), POINTER :: Inst
605 : #if defined ( MODEL_GEOS )
606 : CHARACTER(LEN=2047) :: TuningTable
607 : CHARACTER(LEN=2047), PARAMETER :: TuningTable_Default =
608 : & 'DustDead_TuningTable.txt'
609 : #endif
610 :
611 : !=================================================================
612 : ! HCOX_DUST_DEAD_INIT begins here!
613 : !=================================================================
614 0 : LOC = 'HCOX_DUST_DEAD_INIT (HCOX_DUSTDEAD_MOD.F)'
615 :
616 : ! Extension Nr.
617 0 : ExtNr = GetExtNr( HcoState%Config%ExtList, TRIM(ExtName) )
618 0 : IF ( ExtNr <= 0 ) RETURN
619 :
620 : ! Enter
621 0 : CALL HCO_ENTER ( HcoState%Config%Err, LOC, RC )
622 0 : IF ( RC /= HCO_SUCCESS ) THEN
623 0 : CALL HCO_ERROR( 'ERROR 11', RC, THISLOC=LOC )
624 0 : RETURN
625 : ENDIF
626 :
627 : ! Create AeroCom instance for this simulation
628 0 : Inst => NULL()
629 0 : CALL InstCreate ( ExtNr, ExtState%DustDead, Inst, RC )
630 0 : IF ( RC /= HCO_SUCCESS ) THEN
631 : CALL HCO_ERROR (
632 0 : & 'Cannot create DEAD instance', RC )
633 0 : RETURN
634 : ENDIF
635 :
636 : ! Check for dust alkalinity option
637 0 : Inst%ExtNrAlk = GetExtNr( HcoState%Config%ExtList, 'DustAlk')
638 :
639 : ! Get horizontal dimensions
640 0 : I = HcoState%NX
641 0 : J = HcoState%NY
642 :
643 : !-----------------------------------------------------------------
644 : ! Get species IDs
645 : !-----------------------------------------------------------------
646 :
647 : CALL HCO_GetExtHcoID( HcoState, ExtNr, Inst%HcoIDs,
648 0 : & SpcNames, nSpc, RC)
649 0 : IF ( RC /= HCO_SUCCESS ) THEN
650 0 : CALL HCO_ERROR( 'ERROR 12', RC, THISLOC=LOC )
651 0 : RETURN
652 : ENDIF
653 :
654 : ! Get the dust alkalinity species defined for DustAlk option
655 0 : IF ( Inst%ExtNrAlk > 0 ) THEN
656 : CALL HCO_GetExtHcoID( HcoState, Inst%ExtNrAlk,
657 : & Inst%HcoIDsAlk,
658 0 : & SpcNamesAlk, nSpcAlk, RC)
659 0 : IF ( RC /= HCO_SUCCESS ) THEN
660 0 : CALL HCO_ERROR( 'ERROR 13', RC, THISLOC=LOC )
661 0 : RETURN
662 : ENDIF
663 : ENDIF
664 :
665 : ! Sanity check
666 0 : IF ( nSpc /= NBINS ) THEN
667 0 : MSG = 'Dust DEAD model does not have four species!'
668 0 : CALL HCO_ERROR(MSG, RC )
669 0 : RETURN
670 : ENDIF
671 :
672 : ! Set scale factor: first try to read from configuration file. If
673 : ! not specified, call wrapper function which sets teh scale factor
674 : ! based upon compiler switches.
675 : CALL GetExtOpt( HcoState%Config, ExtNr,
676 : & 'Mass tuning factor',
677 0 : & OptValDp=TmpScal, Found=FOUND, RC=RC )
678 0 : IF ( RC /= HCO_SUCCESS ) THEN
679 0 : CALL HCO_ERROR( 'ERROR 14', RC, THISLOC=LOC )
680 0 : RETURN
681 : ENDIF
682 :
683 : ! Set parameter FLX_MSS_FDG_FCT to specified tuning factor as
684 : ! defined in configuration file
685 0 : IF ( FOUND ) THEN
686 0 : Inst%FLX_MSS_FDG_FCT = TmpScal
687 : ELSE
688 0 : Inst%FLX_MSS_FDG_FCT = -999.0e0
689 : ENDIF
690 :
691 : #if defined ( MODEL_GEOS )
692 : ! Determine mass flux tuning factor based on grid resolution
693 : IF ( Inst%FLX_MSS_FDG_FCT == -999.0e0 ) THEN
694 : CALL GetExtOpt( HcoState%Config, ExtNr,
695 : & 'Mass tuning table',
696 : & OptValChar=TuningTable, Found=FOUND, RC=RC )
697 : IF ( .NOT. FOUND ) TuningTable = TuningTable_Default
698 : CALL ReadTuningFactor(HcoState, TuningTable,
699 : & Inst%FLX_MSS_FDG_FCT, RC)
700 : IF ( RC /= HCO_SUCCESS ) THEN
701 : CALL HCO_ERROR( 'ERROR ReadTuningFactor', RC, THISLOC=LOC )
702 : RETURN
703 : ENDIF
704 : ENDIF
705 : #endif
706 :
707 : ! Error
708 0 : IF ( Inst%FLX_MSS_FDG_FCT == -999.0e0 ) THEN
709 : MSG = 'Mass flux tuning factor not defined. ' //
710 : & 'Please explicitly set it by modifying the line ' //
711 0 : & '` --> Mass tuning factor: XX.X` in HEMCO_Config.rc. '
712 : CALL HCO_ERROR(MSG,
713 0 : & RC, THISLOC='HCOX_DustDead_Init')
714 0 : RETURN
715 : ENDIF
716 :
717 : ! Verbose mode
718 0 : IF ( HcoState%amIRoot ) THEN
719 :
720 : ! Write the name of the extension regardless of the verbose setting
721 0 : msg = 'Using HEMCO extension: DustDead (dust mobilization)'
722 0 : IF ( HCO_IsVerb( HcoState%Config%Err ) ) THEN
723 0 : CALL HCO_Msg( HcoState%Config%Err, msg, sep1='-' ) ! with separator
724 : ELSE
725 0 : CALL HCO_Msg( msg, verb=.TRUE. ) ! w/o separator
726 : ENDIF
727 :
728 : ! Write all other messages as debug printout only
729 0 : IF ( Inst%ExtNrAlk > 0 ) THEN
730 0 : MSG = 'Use dust alkalinity option'
731 0 : CALL HCO_MSG(HcoState%Config%Err,MSG, SEP1='-' )
732 : ENDIF
733 :
734 0 : MSG = 'Use the following species (Name: HcoID):'
735 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
736 0 : DO N = 1, nSpc
737 0 : WRITE(MSG,*) TRIM(SpcNames(N)), ':', Inst%HcoIDs(N)
738 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
739 : ENDDO
740 0 : IF ( Inst%ExtNrAlk > 0 ) THEN
741 0 : DO N = 1, nSpcAlk
742 0 : WRITE(MSG,*) TRIM(SpcNamesAlk(N)), ':', Inst%HcoIDsAlk(N)
743 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
744 : ENDDO
745 : ENDIF
746 :
747 0 : WRITE(MSG,*) 'Global mass flux tuning factor: ',
748 0 : & Inst%FLX_MSS_FDG_FCT
749 0 : CALL HCO_MSG(HcoState%Config%Err,MSG,SEP2='-')
750 :
751 : ENDIF
752 :
753 : !-----------------------------------------------------------------
754 : ! Init module arrays
755 : !-----------------------------------------------------------------
756 :
757 0 : ALLOCATE( Inst%ERD_FCT_GEO( HcoState%NX, HcoState%NY), STAT=AS )
758 0 : IF ( AS /= 0 ) THEN
759 0 : msg = 'Could not allocate Inst%ERD_FCT_GEO!'
760 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
761 0 : RETURN
762 : ENDIF
763 0 : Inst%ERD_FCT_GEO = 0.0_hp
764 :
765 0 : ALLOCATE( Inst%SRCE_FUNC( HcoState%NX, HcoState%NY), STAT=AS )
766 : IF ( AS /= 0 ) THEN
767 0 : msg = 'Could not allocate Inst%SRCE_FUNC!'
768 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
769 0 : RETURN
770 : ENDIF
771 0 : Inst%SRCE_FUNC = 0.0_hp
772 :
773 0 : ALLOCATE( Inst%LND_FRC_DRY( HcoState%NX, HcoState%NY), STAT=AS )
774 : IF ( AS /= 0 ) THEN
775 0 : msg = 'Could not allocate Inst%LND_FRC_DRY!'
776 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
777 0 : RETURN
778 : ENDIF
779 0 : Inst%LND_FRC_DRY = 0.0_hp
780 :
781 0 : ALLOCATE( Inst%MSS_FRC_CACO3( HcoState%NX, HcoState%NY), STAT=AS )
782 : IF ( AS /= 0 ) THEN
783 0 : msg = 'Could not allocate Inst%MSS_FRC_CACO3!'
784 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
785 0 : RETURN
786 : ENDIF
787 0 : Inst%MSS_FRC_CACO3 = 0.0_hp
788 :
789 0 : ALLOCATE( Inst%MSS_FRC_CLY( HcoState%NX, HcoState%NY), STAT=AS )
790 : IF ( AS /= 0 ) THEN
791 0 : msg = 'Could not allocate Inst%MSS_FRC_CLY!'
792 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
793 0 : RETURN
794 : ENDIF
795 0 : Inst%MSS_FRC_CLY = 0.0_hp
796 :
797 0 : ALLOCATE( Inst%MSS_FRC_SND( HcoState%NX, HcoState%NY), STAT=AS )
798 : IF ( AS /= 0 ) THEN
799 0 : msg = 'Could not allocate Inst%MSS_FRC_SND!'
800 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
801 0 : RETURN
802 : ENDIF
803 0 : Inst%MSS_FRC_SND = 0.0_hp
804 :
805 0 : ALLOCATE( Inst%SFC_TYP( HcoState%NX, HcoState%NY), STAT=AS )
806 : IF ( AS /= 0 ) THEN
807 0 : msg = 'Could not allocate Inst%SFC_TYP!'
808 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
809 0 : RETURN
810 : ENDIF
811 0 : Inst%SFC_TYP = 0.0_hp
812 :
813 0 : ALLOCATE( Inst%VAI_DST( HcoState%NX, HcoState%NY), STAT=AS )
814 : IF ( AS /= 0 ) THEN
815 0 : msg = 'Could not allocate Inst%VAI_DST!'
816 0 : CALL HCO_ERROR( msg, RC, thisLoc=loc )
817 0 : RETURN
818 : ENDIF
819 0 : Inst%VAI_DST = 0.0_hp
820 :
821 : ! ! Allocate arrays
822 : ! ALLOCATE( Inst%FLX_LW_DWN_SFC( I, J ), STAT=AS )
823 : ! IF ( AS /= 0 ) THEN
824 : ! CALL HCO_ERROR ( 'FLX_LW_DWN_SFC', RC )
825 : ! RETURN
826 : ! ENDIF
827 : ! Inst%FLX_LW_DWN_SFC = 0d0
828 :
829 : ! ALLOCATE( Inst%FLX_SW_ABS_SFC( I, J ), STAT=AS )
830 : ! IF ( AS /= 0 ) THEN
831 : ! CALL HCO_ERROR ( 'FLX_SW_ABS_SFC', RC )
832 : ! RETURN
833 : ! ENDIF
834 : ! Inst%FLX_SW_ABS_SFC = 0d0
835 :
836 : ! ALLOCATE( Inst%TPT_GND( I, J ), STAT=AS )
837 : ! IF ( AS /= 0 ) THEN
838 : ! CALL HCO_ERROR ( 'TPT_GND', RC )
839 : ! RETURN
840 : ! ENDIF
841 : ! Inst%TPT_GND = 0d0
842 :
843 : ! ALLOCATE( Inst%TPT_SOI( I, J ), STAT=AS )
844 : ! IF ( AS /= 0 ) THEN
845 : ! CALL HCO_ERROR ( 'TPT_SOI', RC )
846 : ! RETURN
847 : ! ENDIF
848 : ! Inst%TPT_SOI = 0d0
849 :
850 : ! ALLOCATE( Inst%VWC_SFC( I, J ), STAT=AS )
851 : ! IF ( AS /= 0 ) THEN
852 : ! CALL HCO_ERROR ( 'VWC_SFC', RC )
853 : ! RETURN
854 : ! ENDIF
855 : ! Inst%VWC_SFC = 0d0
856 :
857 : ! ALLOCATE( Inst%SRC_STR( I, J ), STAT=AS )
858 : ! IF ( AS /= 0 ) THEN
859 : ! CALL HCO_ERROR ( 'SRC_STR', RC )
860 : ! RETURN
861 : ! ENDIF
862 : ! Inst%SRC_STR = 0d0
863 :
864 0 : ALLOCATE( Inst%PLN_TYP( 0:28, 3 ), STAT=AS )
865 0 : IF ( AS /= 0 ) THEN
866 0 : CALL HCO_ERROR ( 'PLN_TYP', RC )
867 0 : RETURN
868 : ENDIF
869 0 : Inst%PLN_TYP = 0
870 :
871 0 : ALLOCATE( Inst%PLN_FRC( 0:28, 3 ), STAT=AS )
872 0 : IF ( AS /= 0 ) THEN
873 0 : CALL HCO_ERROR ( 'PLN_FRC', RC )
874 0 : RETURN
875 : ENDIF
876 0 : Inst%PLN_FRC = 0d0
877 :
878 0 : ALLOCATE( Inst%TAI( MVT, 12 ), STAT=AS )
879 0 : IF ( AS /= 0 ) THEN
880 0 : CALL HCO_ERROR ( 'TAI', RC )
881 0 : RETURN
882 : ENDIF
883 0 : Inst%TAI = 0d0
884 :
885 0 : ALLOCATE( Inst%DMT_VWR( NBINS ), STAT=AS )
886 0 : IF ( AS /= 0 ) THEN
887 0 : CALL HCO_ERROR ( 'DMT_VWR', RC )
888 0 : RETURN
889 : ENDIF
890 0 : Inst%DMT_VWR = 0d0
891 :
892 : ! ALLOCATE( Inst%DNS_AER( NBINS ), STAT=AS )
893 : ! IF ( AS /= 0 ) THEN
894 : ! CALL HCO_ERROR ( 'DNS_AER', RC )
895 : ! RETURN
896 : ! ENDIF
897 : ! Inst%DNS_AER = 0d0
898 :
899 0 : ALLOCATE( Inst%OVR_SRC_SNK_FRC( DST_SRC_NBR, NBINS ), STAT=AS )
900 0 : IF ( AS /= 0 ) THEN
901 0 : CALL HCO_ERROR ( 'OVR_SRC_SNK_FRC', RC )
902 0 : RETURN
903 : ENDIF
904 0 : Inst%OVR_SRC_SNK_FRC = 0d0
905 :
906 0 : ALLOCATE( Inst%OVR_SRC_SNK_MSS( DST_SRC_NBR, NBINS ), STAT=AS )
907 0 : IF ( AS /= 0 ) THEN
908 0 : CALL HCO_ERROR ( 'OVR_SRC_SNK_MSS', RC )
909 0 : RETURN
910 : ENDIF
911 0 : Inst%OVR_SRC_SNK_MSS = 0d0
912 :
913 : ! ALLOCATE( Inst%OROGRAPHY( I, J ), STAT=AS )
914 : ! IF ( AS /= 0 ) THEN
915 : ! CALL HCO_ERROR ( 'OROGRAPHY', RC )
916 : ! RETURN
917 : ! ENDIF
918 : ! Inst%OROGRAPHY = 0
919 :
920 : ! Bin size min diameter [m]
921 0 : ALLOCATE( Inst%DMT_MIN( NBINS ), STAT=AS )
922 0 : IF ( AS /= 0 ) THEN
923 0 : CALL HCO_ERROR ( 'DMT_MIN', RC )
924 0 : RETURN
925 : ENDIF
926 0 : Inst%DMT_MIN(1) = 0.2d-6
927 0 : Inst%DMT_MIN(2) = 2.0d-6
928 0 : Inst%DMT_MIN(3) = 3.6d-6
929 0 : Inst%DMT_MIN(4) = 6.0d-6
930 :
931 : ! Bin size max diameter [m]
932 0 : ALLOCATE( Inst%DMT_MAX( NBINS ), STAT=AS )
933 0 : IF ( AS /= 0 ) THEN
934 0 : CALL HCO_ERROR ( 'DMT_MAX', RC )
935 0 : RETURN
936 : ENDIF
937 0 : Inst%DMT_MAX(1) = 2.0d-6
938 0 : Inst%DMT_MAX(2) = 3.6d-6
939 0 : Inst%DMT_MAX(3) = 6.0d-6
940 0 : Inst%DMT_MAX(4) = 1.2d-5
941 :
942 : ! DMT_VMA_SRC: D'Almeida's (1987) "Background" modes
943 : ! as default [m] (Zender et al. p.5 Table 1)
944 : ! These modes also summarized in BSM96 p. 73 Table 2
945 : ! Mass median diameter BSM96 p. 73 Table 2
946 0 : ALLOCATE( Inst%DMT_VMA_SRC( DST_SRC_NBR ), STAT=AS )
947 0 : IF ( AS /= 0 ) THEN
948 0 : CALL HCO_ERROR ( 'DMT_VMA_SRC', RC )
949 0 : RETURN
950 : ENDIF
951 0 : Inst%DMT_VMA_SRC(1) = 0.832d-6
952 0 : Inst%DMT_VMA_SRC(2) = 4.82d-6
953 0 : Inst%DMT_VMA_SRC(3) = 19.38d-6
954 :
955 : ! GSD_ANL_SRC: Geometric standard deviation [fraction]
956 : ! BSM96 p. 73 Table 2
957 0 : ALLOCATE( Inst%GSD_ANL_SRC( DST_SRC_NBR ), STAT=AS )
958 0 : IF ( AS /= 0 ) THEN
959 0 : CALL HCO_ERROR ( 'GSD_ANL_SRC', RC )
960 0 : RETURN
961 : ENDIF
962 0 : Inst%GSD_ANL_SRC(1) = 2.10d0
963 0 : Inst%GSD_ANL_SRC(2) = 1.90d0
964 0 : Inst%GSD_ANL_SRC(3) = 1.60d0
965 :
966 : ! MSS_FRC_SRC: Mass fraction BSM96 p. 73 Table 2
967 0 : ALLOCATE( Inst%MSS_FRC_SRC( DST_SRC_NBR ), STAT=AS )
968 0 : IF ( AS /= 0 ) THEN
969 0 : CALL HCO_ERROR ( 'MSS_FRC_SRC', RC )
970 0 : RETURN
971 : ENDIF
972 0 : Inst%MSS_FRC_SRC(1) = 0.036d0
973 0 : Inst%MSS_FRC_SRC(2) = 0.957d0
974 0 : Inst%MSS_FRC_SRC(3) = 0.007d0
975 :
976 : !=================================================================
977 : ! Compute mass overlaps, Mij, between "source" PDFs
978 : ! and size bins (Zender et al., 2K3, Equ. 12, and Table 1)
979 : !=================================================================
980 : CALL OVR_SRC_SNK_FRC_GET( HcoState,
981 : & DST_SRC_NBR, Inst%DMT_VMA_SRC,
982 : & Inst%GSD_ANL_SRC, NBINS,
983 : & Inst%DMT_MIN, Inst%DMT_MAX,
984 0 : & Inst%OVR_SRC_SNK_FRC, RC )
985 0 : IF ( RC /= HCO_SUCCESS ) THEN
986 0 : CALL HCO_ERROR( 'ERROR 15', RC, THISLOC=LOC )
987 0 : RETURN
988 : ENDIF
989 :
990 : !=================================================================
991 : ! Compute OVR_SRC_SNK_MSS, the fraction of dust transported, given
992 : ! the mass overlap, OVR_SRC_SNK_FRC, and the mass fraction
993 : ! MSS_FRC_SRC. OVR_SRC_SNK_MSS is used in routine
994 : ! FLX_MSS_VRT_DST_PRT which partitions the total vertical
995 : ! dust flux into transport
996 : !==============================================================
997 : CALL DST_PSD_MSS( Inst%OVR_SRC_SNK_FRC, Inst%MSS_FRC_SRC,
998 0 : & Inst%OVR_SRC_SNK_MSS, NBINS, DST_SRC_NBR )
999 :
1000 : !=================================================================
1001 : ! Get plant type, cover, and Leaf area index from land sfc model
1002 : !=================================================================
1003 0 : CALL PLN_TYP_GET( Inst%PLN_TYP, Inst%PLN_FRC, Inst%TAI )
1004 :
1005 : ! Activate met fields used by this extension
1006 0 : ExtState%SPHU%DoUse = .TRUE.
1007 0 : ExtState%TK%DoUse = .TRUE.
1008 0 : ExtState%U10M%DoUse = .TRUE.
1009 0 : ExtState%V10M%DoUse = .TRUE.
1010 0 : ExtState%T2M%DoUse = .TRUE.
1011 0 : ExtState%GWETTOP%DoUse = .TRUE.
1012 0 : ExtState%SNOWHGT%DoUse = .TRUE.
1013 0 : ExtState%USTAR%DoUse = .TRUE.
1014 0 : ExtState%Z0%DoUse = .TRUE.
1015 0 : ExtState%FRLAND%DoUse = .TRUE.
1016 0 : ExtState%FRLANDIC%DoUse= .TRUE.
1017 0 : ExtState%FROCEAN%DoUse = .TRUE.
1018 0 : ExtState%FRSEAICE%DoUse= .TRUE.
1019 0 : ExtState%FRLAKE%DoUse = .TRUE.
1020 :
1021 : ! Leave w/ success
1022 0 : Inst => NULL()
1023 0 : IF ( ALLOCATED(SpcNames ) ) DEALLOCATE(SpcNames )
1024 0 : IF ( ALLOCATED(SpcNamesAlk) ) DEALLOCATE(SpcNamesAlk)
1025 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
1026 :
1027 0 : END SUBROUTINE HCOX_DustDead_Init
1028 : !EOC
1029 : !------------------------------------------------------------------------------
1030 : ! Harmonized Emissions Component (HEMCO) !
1031 : !------------------------------------------------------------------------------
1032 : !BOP
1033 : !
1034 : ! !IROUTINE: HCOX_DustDead_Final
1035 : !
1036 : ! !DESCRIPTION: Subroutine HcoX\_DustDead\_Final finalizes the HEMCO
1037 : ! DUST\_DEAD extension.
1038 : !\\
1039 : !\\
1040 : ! !INTERFACE:
1041 : !
1042 0 : SUBROUTINE HCOX_DustDead_Final ( ExtState )
1043 : !
1044 : ! !INPUT PARAMETERS:
1045 : !
1046 : TYPE(Ext_State), POINTER :: ExtState ! Module options
1047 : !
1048 : ! !REVISION HISTORY:
1049 : ! 25 Nov 2013 - C. Keller - Now a HEMCO extension
1050 : ! See https://github.com/geoschem/hemco for complete history
1051 : !EOP
1052 : !------------------------------------------------------------------------------
1053 : !BOC
1054 : !
1055 : ! !LOCAL VARIABLES:
1056 : !
1057 0 : CALL InstRemove ( ExtState%DustDead )
1058 :
1059 0 : END SUBROUTINE HCOX_DustDead_Final
1060 : !EOC
1061 : !------------------------------------------------------------------------------
1062 : ! Harmonized Emissions Component (HEMCO) !
1063 : !------------------------------------------------------------------------------
1064 : !
1065 : !******************************************************************************
1066 : ! ORIGINAL ROUTINES FOLLOW BELOW
1067 : !******************************************************************************
1068 :
1069 0 : SUBROUTINE DST_MBL( HcoState, ExtState, Inst,
1070 : & DOY, HGT_MDP, LAT_IDX,
1071 0 : & LAT_RDN, ORO, PRS_DLT,
1072 0 : & PRS_MDP, Q_H2O_VPR, DSRC,
1073 0 : & SNW_HGT_LQD, TM_ADJ, TPT_MDP,
1074 0 : & TPT_PTN_MDP, WND_MRD_MDP, WND_ZNL_MDP,
1075 : & NSTEP, RC )
1076 : !
1077 : !******************************************************************************
1078 : ! Subroutine DST_MBL is the driver for aerosol mobilization (DEAD model).
1079 : ! It is designed to require only single layer surface fields, allowing for
1080 : ! easier implementation. DST_MBL is called once per latitude. Modified
1081 : ! for GEOS-CHEM by Duncan Fairlie and Bob Yantosca.
1082 : ! (tdf, bmy, 1/25/07, 12/18/09)
1083 : !
1084 : ! Arguments as Input:
1085 : ! ============================================================================
1086 : ! (1 ) DOY (REAL*8 ) : Day of year [1.0..366.0) [unitless]
1087 : ! (2 ) HGT_MDP (REAL*8 ) : Midpoint height above surface [m ]
1088 : ! (3 ) LAT_IDX (INTEGER) : Model latitude index [unitless]
1089 : ! (4 ) LAT_RDN (REAL*8 ) : Model latitude [radians ]
1090 : ! (5 ) ORO (REAL*8 ) : Orography [fraction]
1091 : ! (6 ) PRS_DLT (REAL*8 ) : Pressure thickness of grid box [Pa ]
1092 : ! (7 ) PRS_MDP (REAL*8 ) : Pressure @ midpoint of grid box [Pa ]
1093 : ! (8 ) Q_H2O_VPR, (REAL*8 ) : Water vapor mixing ratio [kg/kg ]
1094 : ! (9 ) SNW_HGT_LQD (REAL*8 ) : Equivalent liquid water snow depth [m ]
1095 : ! (10) TM_ADJ, (REAL*8 ) : Adjustment timestep [s ]
1096 : ! (11) TPT_MDP, (REAL*8 ) : Temperature [K ]
1097 : ! (12) TPT_PTN_MDP (REAL*8 ) : Midlayer local potential temp. [K ]
1098 : ! (13) WND_MRD_MDP (REAL*8 ) : Meridional wind component (V-wind) [m/s ]
1099 : ! (14) WND_ZNL_MDP (REAL*8 ) : Zonal wind component (U-wind) [m/s ]
1100 : ! (15) FIRST, (LOGICAL) : Logical used ot open output dataset [unitless]
1101 : ! (16) NSTEP (INTEGER) : Iteration counter [unitless]
1102 : !
1103 : ! Arguments as Output:
1104 : ! ============================================================================
1105 : ! (10) DSRC ! O [kg kg-1] Dust mixing ratio increment
1106 : !
1107 : ! NOTES:
1108 : ! (1 ) Cleaned up and added comments. Also force double precision with
1109 : ! "D" exponents. (bmy, 3/30/04)
1110 : ! (2 ) Now get GOCART source function. (tdf, bmy, 1/25/07)
1111 : ! (3 ) Tune nested-domain emissions dust to the same as 2x2.5 simulation
1112 : ! Also tune GEOS-3 1x1 N. America nested-grid dust emissions to
1113 : ! the 4x5 totals from the GEOS-5 4x5 v8-01-01-Run0 benchmark.
1114 : ! (yxw, bmy, dan, 11/6/08)
1115 : ! (4 ) New scale parameter for 2x2.5 GEOS-5 (tdf, jaf, phs, 10/30/09)
1116 : ! (5 ) Defined FLX_MSS_FDG_FCT for GEOS_4 2x2.5, GEOS_5 2x2.5, NESTED_NA and
1117 : ! NESTED_EU. Redefined FLX_MSS_FDG_FCT for NESTED_CH, based upon above
1118 : ! changes. (amv, bmy, 12/18/09)
1119 : ! (6 ) For now treat MERRA like GEOS-5 (bmy, 8/13/10)
1120 : ! 29 Oct 2010 - T. D. Fairlie, R. Yantosca - Retune dust for MERRA 4x5
1121 : ! 08 Feb 2012 - R. Yantosca - For now, use same FLX_MSS_FDG_FCT for
1122 : ! GEOS-5.7.x as for MERRA
1123 : ! 01 Mar 2012 - R. Yantosca - Now use GET_AREA_M2(I,J,L) from grid_mod.F90
1124 : ! 09 Nov 2012 - M. Payer - Replaced all met field arrays with State_Met
1125 : ! derived type object
1126 : ! 5 Jun 2013 - K. Yu - Use 0.5 x 0.666 NA scale factor for the
1127 : ! 0.25 x 0.3125 NA nested simulation
1128 : !******************************************************************************
1129 : !
1130 : ! Arguments
1131 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
1132 : TYPE(Ext_State), POINTER :: ExtState ! Module options
1133 : TYPE(MyInst), POINTER :: Inst
1134 : INTEGER, INTENT(IN) :: LAT_IDX
1135 : REAL*8, INTENT(IN) :: DOY
1136 : REAL*8, INTENT(IN) :: HGT_MDP(HcoState%NX)
1137 : REAL*8, INTENT(IN) :: LAT_RDN
1138 : REAL*8, INTENT(IN) :: ORO(HcoState%NX)
1139 : REAL*8, INTENT(IN) :: PRS_DLT(HcoState%NX)
1140 : REAL*8, INTENT(IN) :: PRS_MDP(HcoState%NX)
1141 : REAL*8, INTENT(IN) :: Q_H2O_VPR(HcoState%NX)
1142 : REAL*8, INTENT(IN) :: SNW_HGT_LQD(HcoState%NX)
1143 : REAL*8, INTENT(IN) :: TM_ADJ
1144 : REAL*8, INTENT(IN) :: TPT_MDP(HcoState%NX)
1145 : REAL*8, INTENT(IN) :: TPT_PTN_MDP(HcoState%NX)
1146 : REAL*8, INTENT(IN) :: WND_MRD_MDP(HcoState%NX)
1147 : REAL*8, INTENT(IN) :: WND_ZNL_MDP(HcoState%NX)
1148 : INTEGER, INTENT(IN) :: NSTEP
1149 : REAL*8, INTENT(INOUT) :: DSRC(HcoState%NX, NBINS)
1150 : INTEGER, INTENT(INOUT) :: RC
1151 :
1152 : !--------------
1153 : ! Parameters
1154 : !--------------
1155 :
1156 : ! Reference height for mobilization processes [m]
1157 : REAL*8, PARAMETER :: HGT_RFR = 10.0d0
1158 :
1159 : ! Zero plane displacement for erodible surfaces [m]
1160 : REAL*8, PARAMETER :: HGT_ZPD_MBL = 0.0d0
1161 :
1162 : ! Set roughness length momentum for erodible surfaces, S&P, p. 858. [m]
1163 : REAL*8, PARAMETER :: RGH_MMN_MBL = 1.0d-3
1164 :
1165 : ! rgh_mmn_smt set to 33.3e-6 um, MaB95 p. 16426 recommend 10.0e-6
1166 : ! Smooth roughness length MaB95 p. 16426, MaB97 p. 4392, GMB98 p. 6207
1167 : ! [m] Z0,m,s
1168 : REAL*8, PARAMETER :: RGH_MMN_SMT = 33.3d-6
1169 :
1170 : ! Minimum windspeed used for mobilization [m/s]
1171 : REAL*8, PARAMETER :: WND_MIN_MBL = 1.0d0
1172 :
1173 : !--------------
1174 : ! Local Output
1175 : !--------------
1176 0 : REAL*8 DST_SLT_FLX_RAT_TTL(HcoState%NX) ! [m-1] Ratio of vertical dust flux to
1177 : ! streamwise mass flux
1178 0 : REAL*8 FLX_MSS_HRZ_SLT_TTL(HcoState%NX) ! [kg/m/s] Vertically integrated
1179 : ! streamwise mass flux
1180 0 : REAL*8 FLX_MSS_VRT_DST_TTL(HcoState%NX) ! [kg/m2/s] Total vertical mass
1181 : ! flux of dust
1182 0 : REAL*8 FRC_THR_NCR_DRG(HcoState%NX) ! [frc] Threshold friction velocity
1183 : ! increase from roughness
1184 0 : REAL*8 FRC_THR_NCR_WTR(HcoState%NX) ! [frc] Threshold friction velocity
1185 : ! increase from moisture
1186 0 : REAL*8 FLX_MSS_VRT_DST(HcoState%NX,NBINS) ! [kg/m2/s] Vertical mass flux
1187 : ! of dust
1188 0 : REAL*8 HGT_ZPD(HcoState%NX) ! [m] Zero plane displacement
1189 0 : REAL*8 LND_FRC_MBL_SLICE(HcoState%NX) ! [frc] Bare ground fraction
1190 0 : REAL*8 MNO_LNG(HcoState%NX) ! [m] Monin-Obukhov length
1191 0 : REAL*8 WND_FRC(HcoState%NX) ! [m/s] Friction velocity
1192 0 : REAL*8 WND_FRC_GEOS(HcoState%NX) ! [m/s] Friction velocity
1193 0 : REAL*8 Z0_GEOS(HcoState%NX) ! [m] roughness height
1194 0 : REAL*8 SNW_FRC(HcoState%NX) ! [frc] Fraction of surface covered
1195 : ! by snow
1196 : REAL*8 TRN_FSH_VPR_SOI_ATM(HcoState%NX) ! [frc] Transfer efficiency of vapor
1197 : ! from soil to atmosphere
1198 0 : REAL*8 wnd_frc_slt(HcoState%NX) ! [m/s] Saltating friction velocity
1199 0 : REAL*8 WND_FRC_THR_SLT(HcoState%NX) ! [m/s] Threshold friction velocity
1200 : ! for saltation
1201 0 : REAL*8 WND_MDP(HcoState%NX) ! [m/s] Surface layer mean wind speed
1202 0 : REAL*8 WND_RFR(HcoState%NX) ! [m/s] Wind speed at reference height
1203 0 : REAL*8 WND_RFR_THR_SLT(HcoState%NX) ! [m/s] Threshold 10 m wind speed for
1204 : ! saltation
1205 :
1206 : LOGICAL FLG_CACO3 ! [FLG] Activate CaCO3 tracer
1207 0 : LOGICAL FLG_MBL_SLICE(HcoState%NX) ! [flg] Mobilization candidates
1208 : CHARACTER(80) FL_OUT ! [sng] Name of netCDF output file
1209 : INTEGER I ! [idx] Counting index
1210 : INTEGER M ! [idx] Counting index
1211 : INTEGER MBL_NBR ! [nbr] Number of mobilization candidates
1212 0 : INTEGER SFC_TYP_SLICE(HcoState%NX) ! [idx] LSM surface type lat slice (0..28)
1213 0 : REAL*8 CND_TRM_SOI(HcoState%NX) ! [W/m/K] Soil thermal conductivity
1214 0 : REAL*8 DNS_MDP(HcoState%NX) ! [kg/m3] Midlayer density
1215 : REAL*8 FLX_LW_DWN_SFC_SLICE(HcoState%NX) ! [W/m2] Longwave downwelling flux
1216 : ! at surface
1217 : REAL*8 FLX_SW_ABS_SFC_SLICE(HcoState%NX) ! [W/m2] Solar flux absorbed by ground
1218 :
1219 0 : REAL*8 LND_FRC_DRY_SLICE(HcoState%NX) ! [frc] Dry land fraction
1220 0 : REAL*8 MBL_BSN_FCT_SLICE(HcoState%NX) ! [frc] Erodibility factor
1221 0 : REAL*8 MSS_FRC_CACO3_SLICE(HcoState%NX) ! [frc] Mass fraction of CaCO3
1222 0 : REAL*8 MSS_FRC_CLY_SLICE(HcoState%NX) ! [frc] Mass fraction of clay
1223 0 : REAL*8 MSS_FRC_SND_SLICE(HcoState%NX) ! [frc] Mass fraction of sand
1224 :
1225 : ! GOCART source function (tdf, bmy, 1/25/07)
1226 0 : REAL*8 SRCE_FUNC_SLICE(HcoState%NX) ! GOCART source function
1227 :
1228 0 : REAL*8 LVL_DLT(HcoState%NX) ! [m] Soil layer thickness
1229 0 : REAL*8 MPL_AIR(HcoState%NX) ! [kg/m2] Air mass path in layer
1230 :
1231 : REAL*8 TM_DLT ! [s] Mobilization timestep
1232 0 : REAL*8 TPT_GND_SLICE(HcoState%NX) ! [K] Ground temperature
1233 0 : REAL*8 TPT_SOI_SLICE(HcoState%NX) ! [K] Soil temperature
1234 : REAL*8 TPT_SOI_FRZ ! [K] Temperature of frozen soil
1235 : REAL*8 TPT_VRT_MDP ! [K] Midlayer virtual temperature
1236 0 : REAL*8 VAI_DST_SLICE(HcoState%NX) ! [m2/m2] Vegetation area index,
1237 : ! one-sided
1238 0 : REAL*8 VWC_DRY(HcoState%NX) ! [m3/s] Dry volumetric water content
1239 : ! (no E-T)
1240 0 : REAL*8 VWC_OPT(HcoState%NX) ! [m3/m3] E-T optimal volumetric water
1241 : ! content
1242 0 : REAL*8 VWC_SAT(HcoState%NX) ! [m3/m3] Saturated volumetric water
1243 : ! content (sand-dependent)
1244 0 : REAL*8 VWC_SFC_SLICE(HcoState%NX) ! [m3/m3] Volumetric water content
1245 0 : REAL*8 GWC_SFC(HcoState%NX) ! [kg/kg] Gravimetric water content
1246 0 : REAL*8 RGH_MMN(HcoState%NX) ! [m] Roughness length momentum
1247 : REAL*8 W10M
1248 :
1249 : ! GCM diagnostics
1250 : ! Dust tendency due to gravitational settling [kg/kg/s]
1251 0 : REAL*8 Q_DST_TND_MBL(HcoState%NX,NBINS)
1252 :
1253 : ! Total dust tendency due to gravitational settling [kg/kg/s]
1254 0 : REAL*8 Q_DST_TND_MBL_TTL(HcoState%NX)
1255 :
1256 : ! Temperature
1257 : REAL(dp) :: TMP
1258 :
1259 : ! For error handling
1260 : CHARACTER(LEN=255) :: MSG, LOC
1261 :
1262 : !=================================================================
1263 : ! DST_MBL begins here!
1264 : !=================================================================
1265 0 : LOC = 'DST_MBL (HCOX_DUSTDEAD_MOD.F)'
1266 :
1267 : ! Start
1268 0 : RC = HCO_SUCCESS
1269 :
1270 : ! Time step [s]
1271 0 : TM_DLT = TM_ADJ
1272 :
1273 : ! Freezing pt of soil [K] -- assume it's 0C
1274 0 : TPT_SOI_FRZ = TPT_FRZ_PNT
1275 :
1276 : ! Initialize output fluxes and tendencies
1277 0 : Q_DST_TND_MBL(:,:) = 0.0D0 ! [kg kg-1 s-1]
1278 0 : Q_DST_TND_MBL_TTL(:) = 0.0D0 ! [kg kg-1 s-1]
1279 0 : FLX_MSS_VRT_DST(:,:) = 0.0D0 ! [kg m-2 s-1]
1280 0 : FLX_MSS_VRT_DST_TTL(:) = 0.0D0 ! [kg m-2 s-1]
1281 0 : FRC_THR_NCR_WTR(:) = 0.0D0 ! [frc]
1282 0 : WND_RFR(:) = 0.0D0 ! [m s-1]
1283 0 : WND_FRC(:) = 0.0D0 ! [m s-1]
1284 0 : WND_FRC_SLT(:) = 0.0D0 ! [m s-1]
1285 0 : WND_FRC_THR_SLT(:) = 0.0D0 ! [m s-1]
1286 0 : WND_RFR_THR_SLT(:) = 0.0D0 ! [m s-1]
1287 0 : HGT_ZPD(:) = HGT_ZPD_MBL ! [m]
1288 :
1289 0 : DSRC(:,:) = 0.0D0
1290 :
1291 : !=================================================================
1292 : ! Compute necessary derived fields
1293 : !=================================================================
1294 0 : DO I = 1, HcoState%NX
1295 :
1296 : ! Stop occasional haywire model runs
1297 : ! IF ( TPT_MDP(I) > 350.0d0 ) THEN
1298 : ! MSG = 'TPT_MDP(i) > 350.0'
1299 : ! CALL HCO_ERROR(MSG, RC, THISLOC='DST_MBL' )
1300 : ! RETURN
1301 : ! ENDIF
1302 : ! Now simply restrict to 350K, rather than crashing
1303 0 : IF ( TPT_MDP(I) > 350.0d0 ) THEN
1304 : TMP = 350.0d0
1305 : ELSE
1306 0 : TMP = TPT_MDP(I)
1307 : ENDIF
1308 :
1309 : ! Midlayer virtual temperature [K]
1310 : TPT_VRT_MDP = TMP
1311 0 : & * (1.0d0 + EPS_H2O_RCP_M1 * Q_H2O_VPR(I))
1312 :
1313 : ! Density at center of gridbox [kg/m3]
1314 : DNS_MDP(I) = PRS_MDP(I)
1315 0 : & / (TPT_VRT_MDP * GAS_CST_DRY_AIR)
1316 :
1317 : ! Commented out
1318 : !cApproximate surface virtual temperature (uses midlayer moisture)
1319 : !c tpt_vrt_sfc=tpt_sfc(i)*(1.0+eps_H2O_rcp_m1*q_H2O_vpr(i)) ! [K]
1320 : !c
1321 : !c Surface density
1322 : !c dns_sfc(i)=prs_sfc(i)/(tpt_vrt_sfc*gas_cst_dry_air) ! [kg m-3]
1323 :
1324 : ! Mass of air currently in gridbox [kg/m2]
1325 0 : MPL_AIR(I) = PRS_DLT(I) * GRV_SFC_RCP
1326 :
1327 : ! Mean surface layer horizontal wind speed
1328 : WND_MDP(I) = SQRT( WND_ZNL_MDP(I)*WND_ZNL_MDP(I)
1329 0 : & + WND_MRD_MDP(I)*WND_MRD_MDP(I) )
1330 :
1331 : ENDDO
1332 :
1333 : !=================================================================
1334 : ! Gather input variables from GEOS-CHEM modules etc.
1335 : !=================================================================
1336 :
1337 : ! Get LSM Surface type (0..28)
1338 : CALL SFC_TYP_GET( HcoState, ExtState, Inst,
1339 0 : & LAT_IDX, SFC_TYP_SLICE, RC )
1340 0 : IF ( RC /= HCO_SUCCESS ) THEN
1341 0 : CALL HCO_ERROR( 'ERROR 16', RC, THISLOC=LOC )
1342 0 : RETURN
1343 : ENDIF
1344 :
1345 : ! Get erodability and mass fractions
1346 : CALL SOI_TXT_GET(
1347 : & HcoState, ! Hemco state object
1348 : & ExtState, Inst, ! Extension options
1349 : & LAT_IDX, ! I [idx] Latitude index
1350 : & LND_FRC_DRY_SLICE, ! O [frc] Dry land fraction
1351 : & MBL_BSN_FCT_SLICE, ! O [frc] Erodibility factor
1352 : & MSS_FRC_CACO3_SLICE, ! O [frc] Mass fraction of CaCO3
1353 : & MSS_FRC_CLY_SLICE, ! O [frc] Mass fraction of clay
1354 0 : & MSS_FRC_SND_SLICE ) ! O [frc] Mass fraction of sand
1355 :
1356 : ! Get GOCART source function (tdf, bmy, 1/25/07)
1357 : CALL SRCE_FUNC_GET( ! GOCART source function
1358 : & HcoState, Inst, ! Hemco state object
1359 : & LAT_IDX, ! I [idx] Latitude index
1360 0 : & SRCE_FUNC_SLICE ) ! O [frc] GOCART source function
1361 :
1362 : ! Get volumetric water content from GWET
1363 : CALL VWC_SFC_GET(
1364 : & HcoState, ! Hemco state object
1365 : & LAT_IDX, ! I [idx] Latitude index
1366 : & ExtState%GWETTOP%Arr%Val, ! I [unitless] Top soil moisture
1367 0 : & VWC_SFC_SLICE ) ! O [m3 m-3] Volumetric water content
1368 :
1369 : ! Get surface and soil temperature
1370 : CALL TPT_GND_SOI_GET(
1371 : & HcoState, ! Hemco state object
1372 : & LAT_IDX, ! I [idx] Latitude index!
1373 : & ExtState%T2M%Arr%Val, ! I [K] Sfc temperature at 2m
1374 : & TPT_GND_SLICE, ! O [K] Ground temperature
1375 0 : & TPT_SOI_SLICE ) ! O [K] Soil temperature
1376 :
1377 : ! Get time-varying vegetation area index
1378 : CALL DST_TVBDS_GET(
1379 : & Inst, ! # of lons
1380 : & HcoState%NX, ! # of lons
1381 : & LAT_IDX, ! I [idx] Latitude index
1382 0 : & VAI_DST_SLICE) ! O [m2 m-2] Vegetation area index, one-sided
1383 :
1384 : ! Get fraction of surface covered by snow
1385 : CALL SNW_FRC_GET(
1386 : & HcoState, ! Hemco state object
1387 : & SNW_HGT_LQD, ! I [m] Equivalent liquid water snow depth
1388 0 : & SNW_FRC ) ! O [frc] Fraction of surface covered by snow
1389 :
1390 : !=================================================================
1391 : ! Use the variables retrieved above to compute the fraction
1392 : ! of each gridcell suitable for dust mobilization
1393 : !=================================================================
1394 : CALL LND_FRC_MBL_GET(
1395 : % HcoState,
1396 : & DOY, ! I [day] Day of year [1.0..366.0)
1397 : & FLG_MBL_SLICE, ! O [flg] Mobilization candidate flag
1398 : & LAT_RDN, ! I [rdn] Latitude
1399 : & LND_FRC_DRY_SLICE, ! I [frc] Dry land fraction
1400 : & LND_FRC_MBL_SLICE, ! O [frc] Bare ground fraction
1401 : & MBL_NBR, ! O [flg] Number of mobilization candidates
1402 : & ORO, ! I [frc] Orography
1403 : & SFC_TYP_SLICE, ! I [idx] LSM surface type (0..28)
1404 : & SNW_FRC, ! I [frc] Fraction of surface covered by snow
1405 : & TPT_SOI_SLICE, ! I [K] Soil temperature
1406 : & TPT_SOI_FRZ, ! I [K] Temperature of frozen soil
1407 : & VAI_DST_SLICE, ! I [m2 m-2] Vegetation area index, one-sided
1408 0 : & RC )
1409 0 : IF ( RC /= HCO_SUCCESS ) THEN
1410 0 : CALL HCO_ERROR( 'ERROR 17', RC, THISLOC=LOC )
1411 0 : RETURN
1412 : ENDIF
1413 :
1414 : ! Much ado about nothing
1415 0 : if (mbl_nbr == 0) then
1416 : goto 737
1417 : endif
1418 :
1419 : !=================================================================
1420 : ! Compute time-invariant hydrologic properties
1421 : ! NB flg_mbl IS time-dependent, so keep this in time loop.
1422 : !=================================================================
1423 : CALL HYD_PRP_GET( ! NB: These properties are time-invariant
1424 : & HcoState,
1425 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1426 : & MSS_FRC_CLY_SLICE, ! I [frc] Mass fraction clay
1427 : & MSS_FRC_SND_SLICE, ! I [frc] Mass fraction sand
1428 : & VWC_DRY, ! O [m3/m3] Dry vol'mtric water content (no E-T)
1429 : & VWC_OPT, ! O [m3/m3] E-T optimal volumetric water content
1430 0 : & VWC_SAT) ! O [m3/m3] Saturated volumetric water content
1431 :
1432 0 : CND_TRM_SOI(:) = 0.0D0
1433 0 : LVL_DLT(:) = 0.0D0
1434 :
1435 : !=================================================================
1436 : ! Get reference wind at 10m
1437 : !=================================================================
1438 0 : DO I = 1, HcoState%NX
1439 0 : W10M = ExtState%U10M%Arr%Val(I,LAT_IDX)**2 +
1440 0 : & ExtState%V10M%Arr%Val(I,LAT_IDX)**2
1441 0 : W10M = SQRT(W10M)
1442 :
1443 : ! add mobilisation criterion flag
1444 0 : IF ( FLG_MBL_SLICE(I) ) THEN
1445 0 : WND_RFR(I) = W10M
1446 : ENDIF
1447 : ENDDO
1448 :
1449 : !=================================================================
1450 : ! Compute standard roughness length. This call is probably
1451 : ! unnecessary, because we are only concerned with mobilisation
1452 : ! candidates, for which roughness length is imposed in blm_mbl
1453 : !=================================================================
1454 : CALL RGH_MMN_GET( ! Set roughness length w/o zero plane displacement
1455 : & HcoState, Inst,
1456 : & ORO, ! I [frc] Orography
1457 : & RGH_MMN, ! O [m] Roughness length momentum
1458 : & SFC_TYP_SLICE, ! I [idx] LSM surface type (0..28)
1459 : & SNW_FRC, ! I [frc] Fraction of surface covered by snow
1460 : & WND_RFR,
1461 0 : & RC ) ! I [m s-1] 10 m wind speed
1462 0 : IF ( RC /= HCO_SUCCESS ) THEN
1463 0 : CALL HCO_ERROR( 'ERROR 18', RC, THISLOC=LOC )
1464 0 : RETURN
1465 : ENDIF
1466 :
1467 : !=================================================================
1468 : ! Introduce Ustar and Z0 from GEOS data
1469 : !=================================================================
1470 0 : DO I = 1, HcoState%NX
1471 :
1472 : ! Just assign for flag mobilisation candidates
1473 0 : IF ( FLG_MBL_SLICE(I) ) THEN
1474 0 : WND_FRC_GEOS(I) = ExtState%USTAR%Arr%Val(I,LAT_IDX)
1475 0 : Z0_GEOS(I) = ExtState%Z0%Arr%Val(I,LAT_IDX)
1476 : ELSE
1477 0 : WND_FRC_GEOS(I) = 0.0D0
1478 0 : Z0_GEOS(I) = 0.0D0
1479 : ENDIF
1480 : ENDDO
1481 :
1482 : !=================================================================
1483 : ! Surface exchange properties over erodible surfaces
1484 : ! DO NEED THIS: Compute Monin-Obukhov and Friction velocities
1485 : ! appropriate for dust producing regions.
1486 : !
1487 : ! Now calling Stripped down (adiabatic) version tdf 10/27/2K3
1488 : ! rgh_mmn_mbl parameter included directly in blm_mbl
1489 : !=================================================================
1490 : CALL BLM_MBL(
1491 : & HcoState,
1492 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1493 : & RGH_MMN, ! I [m] Roughness length momentum, Z0,m
1494 : & WND_RFR, ! I [m s-1] 10 m wind speed
1495 : & MNO_LNG, ! O [m] Monin-Obukhov length
1496 : & WND_FRC,
1497 0 : & RC ) ! O [m s-1] Surface friction velocity, U*
1498 0 : IF ( RC /= HCO_SUCCESS ) THEN
1499 0 : CALL HCO_ERROR( 'ERROR 19', RC, THISLOC=LOC )
1500 0 : RETURN
1501 : ENDIF
1502 :
1503 : !=================================================================
1504 : ! Factor by which surface roughness increases threshold friction
1505 : ! velocity. The sink of atrmospheric momentum into non-erodible
1506 : ! roughness elements Zender et al., expression (3)
1507 : !=================================================================
1508 : !-----------------------------------------------------------------------------
1509 : ! Prior to 1/25/07:
1510 : ! For now, instead of calling this routine to get FRC_THR_NCR_DRG, we will
1511 : ! just set it to 1 (tdf, bmy, 1/25/07)
1512 : !
1513 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
1514 : !
1515 : ! CALL FRC_THR_NCR_DRG_GET(
1516 : ! & HcoState,
1517 : ! & FRC_THR_NCR_DRG, ! O [frc] Factor increases thresh. fric. veloc.
1518 : ! & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1519 : ! & RGH_MMN_MBL, ! I [m] Rgh length momentum for erodible sfcs
1520 : ! & RGH_MMN_SMT, ! I [m] Smooth roughness length, Z0,m,s
1521 : ! & RC )
1522 : !-----------------------------------------------------------------------------
1523 :
1524 : ! Now set roughness factor to 1.0 (tdf, bmy, 1/25/07)
1525 0 : FRC_THR_NCR_DRG(:) = 1.0d0
1526 :
1527 : !=================================================================
1528 : ! Convert volumetric water content to gravimetric water content
1529 : ! NB: Owen effect included in wnd_frc_slt_get
1530 : !=================================================================
1531 : CALL VWC2GWC(
1532 : & HcoState,
1533 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1534 : & GWC_SFC, ! O [kg kg-1] Gravimetric water content
1535 : & VWC_SAT, ! I [m3 m-3] Saturated VWC (sand-dependent)
1536 0 : & VWC_SFC_SLICE ) ! I [m3 m-3] Volumetric water content
1537 :
1538 : !=================================================================
1539 : ! Factor by which soil moisture increases threshold friction
1540 : ! velocity -- i.e. the inhibition of saltation by soil mositure,
1541 : ! Zender et al., exp(5).
1542 : !=================================================================
1543 : CALL FRC_THR_NCR_WTR_GET(
1544 : & HcoState,
1545 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1546 : & FRC_THR_NCR_WTR, ! O [frc] Factor by which moisture increases
1547 : ! threshold friction velocity
1548 : & MSS_FRC_CLY_SLICE, ! I [frc] Mass fraction of clay
1549 0 : & GWC_SFC) ! I [kg kg-1] Gravimetric water content
1550 :
1551 : !=================================================================
1552 : ! Now, compute basic threshold friction velocity for saltation
1553 : ! over dry, bare, smooth ground. fxm: Use surface density not
1554 : ! midlayer density
1555 : !=================================================================
1556 : CALL WND_FRC_THR_SLT_GET(
1557 : & HcoState,
1558 : & FLG_MBL_SLICE, ! I mobilisation flag
1559 : & DNS_MDP, ! I [kg m-3] Midlayer density
1560 : & WND_FRC_THR_SLT, ! O [m s-1] Threshold friction velocity
1561 0 : & RC )
1562 0 : IF ( RC /= HCO_SUCCESS ) THEN
1563 0 : CALL HCO_ERROR( 'ERROR 20', RC, THISLOC=LOC )
1564 0 : RETURN
1565 : ENDIF
1566 :
1567 : ! Adjust threshold friction velocity to account
1568 : ! for moisture and roughness
1569 0 : DO I = 1, HcoState%NX
1570 0 : WND_FRC_THR_SLT(I) = ! [m s-1] Threshold friction velocity
1571 : ! for saltation
1572 : & WND_FRC_THR_SLT(i) ! [m s-1] Threshold for dry, flat ground
1573 : & * FRC_THR_NCR_WTR(i) ! [frc] Adjustment for moisture
1574 0 : & * FRC_THR_NCR_DRG(i) ! [frc] Adjustment for roughness
1575 : ENDDO
1576 :
1577 : ! Threshold saltation wind speed at reference height, 10m
1578 0 : DO I = 1, HcoState%NX
1579 0 : IF ( FLG_MBL_SLICE(I) ) THEN
1580 : WND_RFR_THR_SLT(I) = ! [m s-1] Threshold 10 m wind speed
1581 : ! for saltation
1582 0 : & WND_RFR(I) * WND_FRC_THR_SLT(I) / WND_FRC(i)
1583 : ENDIF
1584 : ENDDO
1585 :
1586 : !=================================================================
1587 : ! Saltation increases friction speed by roughening surface
1588 : ! i.e. Owen effect, Zender et al., expression (4)
1589 : !
1590 : ! Compute the wind friction velocity due to saltation, U*,s
1591 : ! accounting for the Owen effect.
1592 : !=================================================================
1593 : CALL WND_FRC_SLT_GET(
1594 : & HcoState,
1595 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1596 : & WND_FRC, ! I [m s-1] Surface friction velocity
1597 : & WND_FRC_SLT, ! O [m s-1] Saltating friction velocity
1598 : & WND_RFR, ! I [m s-1] Wind speed at reference height
1599 0 : & WND_RFR_THR_SLT ) ! I [m s-1] Thresh. 10 m wind speed for saltation
1600 :
1601 : !=================================================================
1602 : ! Compute horizontal streamwise mass flux, Zender et al., expr. (10)
1603 : !=================================================================
1604 : CALL FLX_MSS_HRZ_SLT_TTL_WHI79_GET(
1605 : & HcoState,
1606 : & DNS_MDP, ! I [kg m-3] Midlayer density
1607 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1608 : & FLX_MSS_HRZ_SLT_TTL, ! O [kg m-1 s-1] Vertically integrated
1609 : ! streamwise mass flux
1610 : & WND_FRC_SLT, ! I [m s-1] Saltating friction velocity
1611 0 : & WND_FRC_THR_SLT ) ! I [m s-1] Threshold friction vel for saltation
1612 :
1613 : !-----------------------------------------------------------------------------
1614 : ! Prior to 1/25/07:
1615 : ! We now multiply by the GOCART source function, and we will ignore
1616 : ! the MBL_BSN_FCT_SLICE. (tdf, bmy, 1/25/07)
1617 : !
1618 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
1619 : !
1620 : !ctdf...prior to Apr/05/06
1621 : ! ! Apply land surface and vegetation limitations
1622 : ! ! and global tuning factor
1623 : ! DO I = 1, HcoState%NX
1624 : ! FLX_MSS_HRZ_SLT_TTL(I) = FLX_MSS_HRZ_SLT_TTL(I) ! [kg m-2 s-1]
1625 : ! & * LND_FRC_MBL_SLICE(i) ! [frc] Bare ground fraction
1626 : ! & * MBL_BSN_FCT_SLICE(i) ! [frc] Erodibility factor
1627 : ! & * FLX_MSS_FDG_FCT ! [frc] Global mass flux tuning
1628 : ! ! factor (empirical)
1629 : ! ENDDO
1630 : !-----------------------------------------------------------------------------
1631 :
1632 : ! Now simply multiply by the GOCART source function.
1633 : ! The vegetation effect has been eliminated in LND_FRC_MBL_GET
1634 : ! and we also ignore MBL_BSN_FCT. (tdf, bmy, 1/25/07)
1635 0 : DO I = 1, HcoState%NX
1636 0 : FLX_MSS_HRZ_SLT_TTL(I) = FLX_MSS_HRZ_SLT_TTL(I) ! [kg m-2 s-1]
1637 : & * LND_FRC_MBL_SLICE(i) ! [frc] Bare ground fraction
1638 : & * Inst%FLX_MSS_FDG_FCT ! [frc] Global mass flux tuning
1639 0 : & * SRCE_FUNC_SLICE(I) ! GOCART source function
1640 : ENDDO
1641 :
1642 : !=================================================================
1643 : ! Compute vertical dust mass flux, see Zender et al., expr. (11).
1644 : !=================================================================
1645 : CALL FLX_MSS_VRT_DST_TTL_MAB95_GET(
1646 : & HcoState,
1647 : & DST_SLT_FLX_RAT_TTL, ! O [m-1] Ratio of vertical dust flux to
1648 : ! streamwise mass flux
1649 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1650 : & FLX_MSS_HRZ_SLT_TTL, ! I [kg/m/s] Vertically integrated
1651 : ! streamwise mass flux
1652 : & FLX_MSS_VRT_DST_TTL, ! O [kg/m2/s] Total vertical mass flux of dust
1653 0 : & MSS_FRC_CLY_SLICE ) ! I [frc] Mass fraction clay
1654 :
1655 : !=================================================================
1656 : ! Now, partition vertical dust mass flux into transport bins
1657 : !
1658 : ! OVR_SRC_SNK_MSS needed in FLX_MSS_VRT_DST_PRT
1659 : ! computed in DST_PSD_MSS, called from "dust_mod.f" (tdf, 3/30/04)
1660 : !=================================================================
1661 : CALL FLX_MSS_VRT_DST_PRT( Inst,
1662 : & HcoState%NX,
1663 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1664 : & FLX_MSS_VRT_DST, ! O [kg m-2 s-1] Vertical mass flux of dust
1665 0 : & FLX_MSS_VRT_DST_TTL) ! I [kg m-2 s-1] Total vertical mass flux of dus
1666 :
1667 : !=================================================================
1668 : ! Mask dust mass flux by tracer mass fraction at source
1669 : !=================================================================
1670 0 : FLG_CACO3 = .FALSE. ! [flg] Activate CaCO3 tracer
1671 : IF ( FLG_CACO3 ) THEN
1672 : CALL FLX_MSS_CACO3_MSK(
1673 : & HcoState,
1674 : & ExtState,
1675 : & Inst%DMT_VWR, ! I [m] Mass weighted diameter resolved
1676 : & FLG_MBL_SLICE, ! I [flg] Mobilization candidate flag
1677 : & FLX_MSS_VRT_DST, ! I/O [kg m-2 s-1] Vert. mass flux of dust
1678 : & MSS_FRC_CACO3_SLICE, ! I [frc] Mass fraction of CaCO3
1679 : & MSS_FRC_CLY_SLICE, ! I [frc] Mass fraction of clay
1680 : & MSS_FRC_SND_SLICE, ! I [frc] Mass fraction of sand
1681 : & RC )
1682 : IF ( RC /= HCO_SUCCESS ) THEN
1683 : CALL HCO_ERROR( 'ERROR 21', RC, THISLOC=LOC )
1684 : RETURN
1685 : ENDIF
1686 : endif
1687 :
1688 : ! Now, flx_mss_vrt_dst has units of kg/m2/sec
1689 :
1690 : ! Fluxes are known, so adjust mixing ratios
1691 0 : DO I=1, HcoState%NX ! NB: Inefficient loop order
1692 0 : IF (FLG_MBL_SLICE(I)) THEN
1693 :
1694 : ! Loop over dust bins
1695 0 : DO M = 1, NBINS
1696 :
1697 : !========================================================
1698 : ! Compute dust mobilisation tendency. Recognise that
1699 : ! what GEOS-CHEM wants is an increment in kg...So,
1700 : ! multiply by DXYP [m2] and tm_adj [sec]
1701 : !========================================================
1702 :
1703 : ! [kg/sec]
1704 0 : Q_DST_TND_MBL(I,M) = FLX_MSS_VRT_DST(I,M)
1705 0 : & *HcoState%Grid%AREA_M2%Val(I,LAT_IDX)
1706 :
1707 : ! Introduce DSRC: dust mixing ratio increment 12/9/2K3
1708 : ! [kg]
1709 0 : DSRC(I,M) = TM_ADJ * Q_DST_TND_MBL(I,M)
1710 :
1711 : ENDDO
1712 : ENDIF
1713 : ENDDO
1714 :
1715 : ! Jump to here when no points are mobilization candidates
1716 : 737 CONTINUE
1717 :
1718 0 : RC = HCO_SUCCESS
1719 :
1720 : ! Return to calling program
1721 : END SUBROUTINE DST_MBL
1722 :
1723 : !------------------------------------------------------------------------------
1724 :
1725 0 : SUBROUTINE SRCE_FUNC_GET( HcoState, Inst, LAT_IDX, SRCE_FUNC_OUT )
1726 : !
1727 : !******************************************************************************
1728 : ! Subroutine SRCE_FUNC_GET returns a latitude slice of the GOCART source
1729 : ! function. This routine is called by DST_MBL. (tdf, bmy, 1/25/07)
1730 : !
1731 : ! Arguments as Input:
1732 : ! ============================================================================
1733 : ! (1 ) LAT_IDX (INTEGER) : GEOS-Chem latitude index
1734 : !
1735 : ! Arguments as Output:
1736 : ! ============================================================================
1737 : ! (1 ) SRCE_FUNC_OUT (REAL*8 ) : GOCART source function [fraction]
1738 : !
1739 : ! NOTES:
1740 : !******************************************************************************
1741 : !
1742 : ! Arguments
1743 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
1744 : TYPE(MyInst), POINTER :: Inst
1745 : INTEGER, INTENT(IN) :: LAT_IDX
1746 : REAL*8, INTENT(OUT) :: SRCE_FUNC_OUT(HcoState%NX)
1747 :
1748 : ! Local variables
1749 : INTEGER :: LON_IDX
1750 :
1751 : !=================================================================
1752 : ! SRCE_FUNC_GET begins here!
1753 : !=================================================================
1754 :
1755 : ! Loop over longitudes
1756 0 : DO LON_IDX = 1, HcoState%NX
1757 :
1758 : ! Save latitude slice in SRCE_FUNC_OUT
1759 0 : SRCE_FUNC_OUT(LON_IDX) = Inst%SRCE_FUNC(LON_IDX,LAT_IDX)
1760 :
1761 : ENDDO
1762 :
1763 : ! Return to calling program
1764 0 : END SUBROUTINE SRCE_FUNC_GET
1765 :
1766 : !------------------------------------------------------------------------------
1767 :
1768 0 : SUBROUTINE SOI_TXT_GET( HcoState, ExtState, Inst, J,
1769 0 : & LND_FRC_DRY_OUT,
1770 0 : & MBL_BSN_FCT_OUT, MSS_FRC_CACO3_OUT,
1771 0 : & MSS_FRC_CLY_OUT, MSS_FRC_SND_OUT )
1772 : !
1773 : !******************************************************************************
1774 : ! Subroutine SOI_GET_TXT returns a latitude slice of soil texture to the
1775 : ! calling program DST_MBL. (tdf, bmy, 3/30/04)
1776 : !
1777 : ! Arguments as Input:
1778 : ! ============================================================================
1779 : ! (1 ) J (INTEGER) : Grid box latitude index
1780 : !
1781 : ! Arguments as Output:
1782 : ! ============================================================================
1783 : ! (2 ) lnd_frc_dry_out (REAL*8 ) : Dry land fraction [fraction]
1784 : ! (3 ) mbl_bsn_fct_out (REAL*8 ) : Erodibility factor [fraction]
1785 : ! (4 ) mss_frc_CaCO3_out (REAL*8 ) : Mass fraction of CaCO3 [fraction]
1786 : ! (5 ) mss_frc_cly_out (REAL*8 ) : Mass fraction of clay [fraction]
1787 : ! (6 ) mss_frc_snd_out (REAL*8 ) : Mass fraction of sand [fraction]
1788 : !
1789 : ! NOTES:
1790 : ! (1 ) Updated comments, cosmetic changes (bmy, 3/30/04)
1791 : !******************************************************************************
1792 : !
1793 :
1794 : ! Arguments
1795 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
1796 : TYPE(Ext_State), POINTER :: ExtState ! Module options
1797 : TYPE(MyInst), POINTER :: Inst
1798 : INTEGER, INTENT(IN) :: J
1799 : REAL*8, INTENT(OUT) :: LND_FRC_DRY_OUT(HcoState%NX)
1800 : REAL*8, INTENT(OUT) :: MBL_BSN_FCT_OUT(HcoState%NX)
1801 : REAL*8, INTENT(OUT) :: MSS_FRC_CACO3_OUT(HcoState%NX)
1802 : REAL*8, INTENT(OUT) :: MSS_FRC_CLY_OUT(HcoState%NX)
1803 : REAL*8, INTENT(OUT) :: MSS_FRC_SND_OUT(HcoState%NX)
1804 :
1805 : ! Local variables
1806 : INTEGER :: I
1807 :
1808 : ! Ad hoc globally uniform clay mass fraction [kg/kg]
1809 : REAL*8, PARAMETER :: MSS_FRC_CLY_GLB = 0.20d0
1810 :
1811 : !=================================================================
1812 : ! SOI_GET_TXT begins here!
1813 : !=================================================================
1814 0 : DO I = 1, HcoState%NX
1815 :
1816 : ! Save dry land fraction slice
1817 0 : LND_FRC_DRY_OUT(I) = Inst%LND_FRC_DRY(I,J)
1818 :
1819 : ! Change surface source distribution to "geomorphic" tdf 12/12/2K3
1820 0 : MBL_BSN_FCT_OUT(I) = Inst%ERD_FCT_GEO(I,J)
1821 :
1822 : !fxm: CaCO3 currently has missing value of
1823 : ! 1.0e36 which causes problems
1824 0 : IF ( Inst%MSS_FRC_CACO3(I,J) <= 1.0D0 ) THEN
1825 0 : MSS_FRC_CACO3_OUT(I) = Inst%MSS_FRC_CACO3(I,J)
1826 : ELSE
1827 0 : MSS_FRC_CACO3_OUT(I) = 0.0D0
1828 : ENDIF
1829 :
1830 : ! fxm Temporarily set mss_frc_cly used in mobilization to globally
1831 : ! uniform SGS value of 0.20, and put excess mass fraction
1832 : ! into sand
1833 0 : MSS_FRC_CLY_OUT(I) = MSS_FRC_CLY_GLB
1834 0 : MSS_FRC_SND_OUT(I) = Inst%MSS_FRC_SND(I,J) +
1835 0 : & Inst%MSS_FRC_CLY(I,J) -
1836 0 : & MSS_FRC_CLY_GLB
1837 :
1838 : ENDDO
1839 :
1840 : ! Return to calling program
1841 0 : END SUBROUTINE SOI_TXT_GET
1842 :
1843 : !------------------------------------------------------------------------------
1844 :
1845 0 : SUBROUTINE SFC_TYP_GET( HcoState, ExtState,
1846 0 : & Inst, J, SFC_TYP_OUT, RC )
1847 : !
1848 : !******************************************************************************
1849 : ! Subroutine SFC_TYP_GET returns a latitude slice of LSM surface type
1850 : ! to the calling programs DST_MBL & DST_DPS_DRY. (tdf, bmy, 3/30/04)
1851 : !
1852 : ! Arguments as Input:
1853 : ! ============================================================================
1854 : ! (1 ) J (INTEGER) : Grid box latitude index
1855 : !
1856 : ! Arguments as Output:
1857 : ! ============================================================================
1858 : ! (1 ) sfc_typ_out (REAL*8 ) : LSM surface type (0..28) [unitless]
1859 : !
1860 : ! NOTES
1861 : ! (1 ) Updated comments & cosmetic changes (bmy, 3/30/04)
1862 : ! (2 ) Added error trap (ckeller, 7/24/2014)
1863 : !******************************************************************************
1864 : !
1865 :
1866 : ! Arguments
1867 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
1868 : TYPE(Ext_State), POINTER :: ExtState
1869 : TYPE(MyInst), POINTER :: Inst
1870 : INTEGER, INTENT(IN) :: J
1871 : INTEGER, INTENT(OUT) :: SFC_TYP_OUT(HcoState%NX)
1872 : INTEGER, INTENT(INOUT) :: RC
1873 :
1874 : ! Local variables
1875 : INTEGER :: I, TMP
1876 : CHARACTER(LEN=255) :: MSG
1877 :
1878 : !=================================================================
1879 : ! SFC_TYP_GET begins here!
1880 : !=================================================================
1881 0 : DO I = 1, HcoState%NX
1882 0 : TMP = INT(Inst%SFC_TYP(I,J))
1883 :
1884 : ! Make sure value is within valid range (1 - NN_SFCTYP).
1885 0 : SFC_TYP_OUT(I) = MAX( MIN(TMP,NN_SFCTYP), 0 )
1886 : ENDDO
1887 :
1888 : ! Return with success
1889 0 : RC = HCO_SUCCESS
1890 :
1891 : ! Return to calling program
1892 0 : END SUBROUTINE SFC_TYP_GET ! end sfc_typ_get()
1893 :
1894 : !------------------------------------------------------------------------------
1895 :
1896 0 : SUBROUTINE TPT_GND_SOI_GET( HcoState, J, TS,
1897 0 : & TPT_GND_OUT, TPT_SOI_OUT )
1898 : !
1899 : !******************************************************************************
1900 : ! Subroutine TPT_GND_SOI_GET returns a latitude slice of soil temperature and
1901 : ! ground temperature to the calling program DST_MBL. (tdf, bmy, 3/30/04)
1902 : !
1903 : ! Arguments as Input:
1904 : ! ============================================================================
1905 : ! (1 ) J (INTEGER) : Grid box latitude index
1906 : ! (2 ) TS (REAL*8) : Surface temperature at 2m [K]
1907 : !
1908 : ! Arguments as Output:
1909 : ! ============================================================================
1910 : ! (2 ) TPT_GND_OUT (REAL*8 ) : Ground temperature array slice [K]
1911 : ! (3 ) tpt_soi_out (REAL*8 ) : Soil temperature array slice [K]
1912 : !
1913 : ! NOTES
1914 : ! (1 ) Updated comments & cosmetic changes (bmy, 3/30/04)
1915 : !******************************************************************************
1916 : !
1917 :
1918 : ! Arguments
1919 : INTEGER, INTENT(IN) :: J
1920 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
1921 : REAL(hp),INTENT(IN) :: TS(HcoState%NX,HcoState%NY)
1922 : REAL*8, INTENT(OUT) :: TPT_GND_OUT(HcoState%NX)
1923 : REAL*8, INTENT(OUT) :: TPT_SOI_OUT(HcoState%NX)
1924 :
1925 : ! Local variables
1926 : INTEGER :: I
1927 :
1928 : !=================================================================
1929 : ! TPT_GND_SOI_GET begins here!
1930 : !=================================================================
1931 :
1932 : ! Use TS from GEOS-CHEM (tdf, 3/30/04)
1933 0 : DO I = 1, HcoState%NX
1934 0 : TPT_GND_OUT(I) = TS(I,J)
1935 0 : TPT_SOI_OUT(I) = TS(I,J)
1936 : ENDDO
1937 :
1938 : ! Return to calling program
1939 0 : END SUBROUTINE TPT_GND_SOI_GET
1940 :
1941 : !------------------------------------------------------------------------------
1942 :
1943 0 : SUBROUTINE VWC_SFC_GET( HcoState, J, GWETTOP, VWC_SFC_OUT )
1944 : !
1945 : !******************************************************************************
1946 : ! Subroutine TPT_GND_SOI_GET returns a latitude slice of volumetric water
1947 : ! content to the calling program DST_MBL. (tdf, bmy, 3/30/04)
1948 : !
1949 : ! Arguments as Input:
1950 : ! ============================================================================
1951 : ! (1 ) J (INTEGER) : Grid box latitude index
1952 : ! (2 ) GWETTOP (REAL*8) : Top soil moisture [unitless]
1953 : !
1954 : ! Arguments as Output:
1955 : ! ============================================================================
1956 : ! VWC_SFC_OUT (REAL*8 ) : Volumetric water content [m3/m3]
1957 : !
1958 : ! NOTES
1959 : ! (1 ) Updated comments & cosmetic changes (bmy, 3/30/04)
1960 : !******************************************************************************
1961 : !
1962 :
1963 : ! Arguments
1964 : INTEGER, INTENT(IN) :: J
1965 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
1966 : REAL(hp), INTENT(IN) :: GWETTOP(HcoState%NX,HcoState%NY)
1967 : REAL*8, INTENT(OUT) :: VWC_SFC_OUT(HcoState%NX)
1968 :
1969 : ! Local variables
1970 : INTEGER :: I
1971 :
1972 : !=================================================================
1973 : ! VWC_SFC_GET begins here!
1974 : !=================================================================
1975 0 : DO I = 1, HcoState%NX
1976 0 : VWC_SFC_OUT(I) = GWETTOP(I,J)
1977 : ENDDO
1978 :
1979 : ! Return to calling program
1980 0 : END SUBROUTINE VWC_SFC_GET
1981 :
1982 : !------------------------------------------------------------------------------
1983 :
1984 : REAL*8 FUNCTION DSVPDT_H2O_LQD_PRK78_FST_SCL( TPT_CLS )
1985 : !
1986 : !******************************************************************************
1987 : ! Function DSVPDT_H2O_LQD_PRK78_FST_SCL returns the derivative of saturation
1988 : ! vapor pressure [Pa] over planar liquid water (tdf, bmy, 3/30/04)
1989 : !
1990 : ! Arguments as Input:
1991 : ! ============================================================================
1992 : ! (1 ) TPT_CLS (REAL*8) : Temperature in Celsius [C]
1993 : !
1994 : ! NOTES:
1995 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
1996 : ! with "D" exponents. (bmy, 3/30/04)
1997 : !******************************************************************************
1998 : !
1999 : ! Arguments
2000 : REAL*8, INTENT(IN) :: TPT_CLS
2001 :
2002 : ! Local variables
2003 : REAL*8, PARAMETER :: C0 = 4.438099984d-01
2004 : REAL*8, PARAMETER :: C1 = 2.857002636d-02
2005 : REAL*8, PARAMETER :: C2 = 7.938054040d-04
2006 : REAL*8, PARAMETER :: C3 = 1.215215065d-05
2007 : REAL*8, PARAMETER :: C4 = 1.036561403d-07
2008 : REAL*8, PARAMETER :: C5 = 3.532421810d-10
2009 : REAL*8, PARAMETER :: C6 =-7.090244804d-13
2010 :
2011 : !=================================================================
2012 : ! DSVPDT_H2O_LQD_PRK78_FST_SCL begins here!
2013 : !=================================================================
2014 :
2015 : ! Return deriv. of saturation vapor pressure [Pa]
2016 : DSVPDT_H2O_LQD_PRK78_FST_SCL = 100.0d0 * ( C0+TPT_CLS *
2017 : & ( C1+TPT_CLS *
2018 : & ( C2+TPT_CLS *
2019 : & ( C3+TPT_CLS *
2020 : & ( C4+TPT_CLS *
2021 : & ( C5+TPT_CLS * C6 ))))))
2022 :
2023 : ! Return to calling program
2024 : END FUNCTION DSVPDT_H2O_LQD_PRK78_FST_SCL
2025 :
2026 : !------------------------------------------------------------------------------
2027 :
2028 : REAL*8 FUNCTION DSVPDT_H2O_ICE_PRK78_FST_SCL( TPT_CLS )
2029 : !
2030 : !******************************************************************************
2031 : ! Function DSVPDT_H2O_ICE_PRK78_FST_SCL returns the derivative of saturation
2032 : ! vapor pressure [Pa] over planar ice water (tdf, bmy, 3/30/04)
2033 : !
2034 : ! Arguments as Input:
2035 : ! ============================================================================
2036 : ! (1 ) TPT_CLS (REAL*8) : Temperature in Celsius [C]
2037 : !
2038 : ! NOTES:
2039 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
2040 : ! with "D" exponents. (bmy, 3/30/04)
2041 : !******************************************************************************
2042 : !
2043 : ! Arguments
2044 : REAL*8, INTENT(IN) :: TPT_CLS
2045 :
2046 : ! Local variables
2047 : REAL*8, PARAMETER :: D0 = 5.030305237d-01
2048 : REAL*8, PARAMETER :: D1 = 3.773255020d-02
2049 : REAL*8, PARAMETER :: D2 = 1.267995369d-03
2050 : REAL*8, PARAMETER :: D3 = 2.477563108d-05
2051 : REAL*8, PARAMETER :: D4 = 3.005693132d-07
2052 : REAL*8, PARAMETER :: D5 = 2.158542548d-09
2053 : REAL*8, PARAMETER :: D6 = 7.131097725d-12
2054 :
2055 : !=================================================================
2056 : ! DSVPDT_H2O_ICE_PRK78_FST_SCL begins here!
2057 : !=================================================================
2058 :
2059 : ! Return deriv. of sat vapor pressure [Pa]
2060 : DSVPDT_H2O_ICE_PRK78_FST_SCL = 100.0D0 * ( D0+TPT_CLS *
2061 : & ( D1+TPT_CLS *
2062 : & ( D2+TPT_CLS *
2063 : & ( D3+TPT_CLS *
2064 : & ( D4+TPT_CLS *
2065 : & ( D5+TPT_CLS * D6 ))))))
2066 :
2067 : ! Return to calling program
2068 : END FUNCTION DSVPDT_H2O_ICE_PRK78_FST_SCL
2069 :
2070 : !------------------------------------------------------------------------------
2071 :
2072 : REAL*8 FUNCTION SVP_H2O_LQD_PRK78_FST_SCL( TPT_CLS )
2073 : !
2074 : !******************************************************************************
2075 : ! Function SVP_H2O_LQD_PRK78_FST_SCL returns the saturation vapor pressure
2076 : ! over planer liquid water [Pa] See Lowe and Ficke (1974) as reported in
2077 : ! PrK78 p. 625. Range of validity is -50 C < T < 50 C. (tdf, bmy, 3/30/04)
2078 : !
2079 : ! Arguments as Input:
2080 : ! ============================================================================
2081 : ! (1 ) TPT_CLS (REAL*8) : Temperature in Celsius [C]
2082 : !
2083 : ! NOTES:
2084 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
2085 : ! with "D" exponents. (bmy, 3/30/04)
2086 : !******************************************************************************
2087 : !
2088 : ! Arguments
2089 : REAL*8, INTENT(IN) :: TPT_CLS
2090 :
2091 : ! Local variables
2092 : REAL*8, PARAMETER :: A0 = 6.107799961d0
2093 : REAL*8, PARAMETER :: A1 = 4.436518521d-01
2094 : REAL*8, PARAMETER :: A2 = 1.428945805d-02
2095 : REAL*8, PARAMETER :: A3 = 2.650648471d-04
2096 : REAL*8, PARAMETER :: A4 = 3.031240396d-06
2097 : REAL*8, PARAMETER :: A5 = 2.034080948d-08
2098 : REAL*8, PARAMETER :: A6 = 6.136820929d-11
2099 :
2100 : !=================================================================
2101 : ! SVP_H2O_LQD_PRK78_FST_SCL begins here!
2102 : !=================================================================
2103 :
2104 : ! Return saturation vapor pressure over liquid water [Pa]
2105 : SVP_H2O_LQD_PRK78_FST_SCL = 100.0D0 * ( A0+TPT_CLS *
2106 : & ( A1+TPT_CLS *
2107 : & ( A2+TPT_CLS *
2108 : & ( A3+TPT_CLS *
2109 : & ( A4+TPT_CLS *
2110 : & ( A5+TPT_CLS * A6 ))))))
2111 :
2112 : ! Return to calling program
2113 : END FUNCTION SVP_H2O_LQD_PRK78_FST_SCL
2114 :
2115 : !------------------------------------------------------------------------------
2116 :
2117 : REAL*8 FUNCTION SVP_H2O_ICE_PRK78_FST_SCL( TPT_CLS )
2118 : !
2119 : !******************************************************************************
2120 : ! Function SVP_H2O_ICE_PRK78_FST_SCL returns the saturation vapor pressure
2121 : ! [Pa] over planar ice water (tdf, bmy, 3/30/04)
2122 : !
2123 : ! Arguments as Input:
2124 : ! ============================================================================
2125 : ! (1 ) TPT_CLS (REAL*8) : Temperature in Celsius [C]
2126 : !
2127 : ! NOTES:
2128 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
2129 : ! with "D" exponents. (bmy, 3/30/04)
2130 : !******************************************************************************
2131 : !
2132 :
2133 : ! Arguments
2134 : REAL*8, INTENT(IN) :: TPT_CLS
2135 :
2136 : ! Local variables
2137 : REAL*8, PARAMETER :: B0 = 6.109177956d0
2138 : REAL*8, PARAMETER :: B1 = 5.034698970d-01
2139 : REAL*8, PARAMETER :: B2 = 1.886013408d-02
2140 : REAL*8, PARAMETER :: B3 = 4.176223716d-04
2141 : REAL*8, PARAMETER :: B4 = 5.824720280d-06
2142 : REAL*8, PARAMETER :: B5 = 4.838803174d-08
2143 : REAL*8, PARAMETER :: B6 = 1.838826904d-10
2144 :
2145 : !=================================================================
2146 : ! SVP_H2O_ICE_PRK78_FST_SCL begins here!
2147 : !=================================================================
2148 :
2149 : ! Return saturation vapor pressure over ice [Pa]
2150 : SVP_H2O_ICE_PRK78_FST_SCL = 100.0D0 * ( B0+TPT_CLS *
2151 : & ( B1+TPT_CLS *
2152 : & ( B2+TPT_CLS *
2153 : & ( B3+TPT_CLS *
2154 : & ( B4+TPT_CLS *
2155 : & ( B5+TPT_CLS * B6 ))))))
2156 :
2157 : ! Return to calling program
2158 : END FUNCTION SVP_H2O_ICE_PRK78_FST_SCL
2159 :
2160 : !------------------------------------------------------------------------------
2161 :
2162 : REAL*8 FUNCTION TPT_BND_CLS_GET( TPT )
2163 : !
2164 : !******************************************************************************
2165 : ! Function TPT_BND_CLS_GET returns the bounded temperature in [C],
2166 : ! (i.e., -50 < T [C] < 50 C), given the temperature in [K].
2167 : ! (tdf, bmy, 3/30/04)
2168 : !
2169 : ! Arguments as Input:
2170 : ! ============================================================================
2171 : ! (1 ) TPT (REAL*8) : Temperature in Kelvin [K]
2172 : !
2173 : ! NOTES:
2174 : !******************************************************************************
2175 : !
2176 : ! Arguments
2177 : REAL*8, INTENT(IN) :: TPT
2178 :
2179 : ! Local variables
2180 : REAL*8, PARAMETER :: TPT_FRZ_PNT=273.15
2181 :
2182 : !=================================================================
2183 : ! TPT_BND_CLS_GET begins here!
2184 : !=================================================================
2185 : TPT_BND_CLS_GET = MIN( 50.0D0, MAX( -50.0D0, ( TPT-TPT_FRZ_PNT)) )
2186 :
2187 : ! Return to calling program
2188 : END FUNCTION TPT_BND_CLS_GET
2189 :
2190 : !------------------------------------------------------------------------------
2191 :
2192 0 : SUBROUTINE GET_ORO( HcoState, ExtState, OROGRAPHY, RC )
2193 : !
2194 : ! !USES:
2195 : !
2196 : USE HCO_GEOTOOLS_MOD, ONLY : HCO_LANDTYPE
2197 : !
2198 : !******************************************************************************
2199 : ! Subroutine GET_ORO creates a 2D orography array, OROGRAPHY, from the
2200 : ! GMAO surface type fraction fields, based on definition of GMAO LWI, with
2201 : ! modification to qualify land ice as ice. Ocean=0 (no ice); Land=1; Ice=2.
2202 : !
2203 : ! Arguments as Output:
2204 : ! ============================================================================
2205 : ! (1 ) OROGRAPHY (INTEGER) : Array for orography flags
2206 : !
2207 : ! NOTES:
2208 : ! (1 ) Added parallel DO-loop (bmy, 4/14/04)
2209 : ! (2 ) Now modified for GCAP and GEOS-5 met fields (swu, bmy, 6/9/05)
2210 : ! (3 ) Now use IS_LAND, IS_WATER, IS_ICE functions from "dao_mod.f"
2211 : ! (bmy, 8/17/05)
2212 : ! 09 Nov 2012 - M. Payer - Replaced all met field arrays with State_Met
2213 : ! derived type object
2214 : !******************************************************************************
2215 : !
2216 :
2217 : ! Arguments
2218 : TYPE(HCO_State), POINTER :: HcoState
2219 : Type(Ext_State), POINTER :: ExtState
2220 : INTEGER, INTENT(OUT ) :: OROGRAPHY(HcoState%NX,
2221 : & HcoState%NY)
2222 : INTEGER, INTENT(INOUT) :: RC
2223 :
2224 : ! Local variables
2225 : INTEGER :: I, J
2226 :
2227 : !=================================================================
2228 : ! GET_ORO begins here!
2229 : !=================================================================
2230 :
2231 : !$OMP PARALLEL DO
2232 : !$OMP+DEFAULT( SHARED )
2233 : !$OMP+PRIVATE( I, J )
2234 0 : DO J = 1, HcoState%NY
2235 0 : DO I = 1, HcoState%NX
2236 :
2237 : ! Set orography to from fraction land type
2238 0 : OROGRAPHY (I,J) = HCO_LANDTYPE( ExtState%FRLAND%Arr%Val(I,J),
2239 0 : & ExtState%FRLANDIC%Arr%Val(I,J),
2240 0 : & ExtState%FROCEAN%Arr%Val(I,J),
2241 0 : & ExtState%FRSEAICE%Arr%Val(I,J),
2242 0 : & ExtState%FRLAKE%Arr%Val(I,J) )
2243 :
2244 : ENDDO
2245 : ENDDO
2246 : !$OMP END PARALLEL DO
2247 :
2248 : ! Return w/ success
2249 0 : RC = HCO_SUCCESS
2250 :
2251 0 : END SUBROUTINE GET_ORO
2252 :
2253 : !------------------------------------------------------------------------------
2254 :
2255 0 : SUBROUTINE HYD_PRP_GET( HcoState, FLG_MBL, MSS_FRC_CLY_SLC,
2256 0 : & MSS_FRC_SND_SLC, VWC_DRY, VWC_OPT,
2257 0 : & VWC_SAT )
2258 : !
2259 : !******************************************************************************
2260 : ! Subroutine HYD_PRP_GET determines hydrologic properties from soil texture.
2261 : ! (tdf, bmy, 3/30/04)
2262 : !
2263 : ! Arguments as Input:
2264 : ! ============================================================================
2265 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [unitless]
2266 : ! (2 ) MSS_FRC_CLY (REAL*8 ) : Mass fraction clay [fraction]
2267 : ! (3 ) MSS_FRC_SND (REAL*8 ) : Mass fraction sand [fraction]
2268 : !
2269 : ! Arguments as Output:
2270 : ! ============================================================================
2271 : ! (4 ) VWC_DRY (REAL*8 ) : Dry volumetric water content (no E-T) [m3/m3]
2272 : ! (5 ) VWC_OPT (REAL*8 ) : E-T optimal volumetric water content [m3/m3]
2273 : ! (6 ) VWC_SAT (REAL*8 ) : Saturated volumetric water content [m3/m3]
2274 : !
2275 : ! NOTES:
2276 : ! (1 ) All I/O for this routine is time-invariant, thus, the hydrologic
2277 : ! properties could be computed once at initialization. However,
2278 : ! FLG_MBL is time-dependent, so we should keep this as-is.
2279 : ! (tdf, 10/27/03)
2280 : !******************************************************************************
2281 : !
2282 :
2283 : ! Arguments
2284 : TYPE(HCO_State), POINTER :: HcoState
2285 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
2286 : REAL*8, INTENT(IN) :: MSS_FRC_CLY_SLC(HcoState%NX)
2287 : REAL*8, INTENT(IN) :: MSS_FRC_SND_SLC(HcoState%NX)
2288 : REAL*8, INTENT(OUT) :: VWC_DRY(HcoState%NX)
2289 : REAL*8, INTENT(OUT) :: VWC_OPT(HcoState%NX)
2290 : REAL*8, INTENT(OUT) :: VWC_SAT(HcoState%NX)
2291 :
2292 : ! Local variables
2293 : INTEGER :: LON_IDX
2294 :
2295 : ! [frc] Exponent "b" for smp (clay-dependent)
2296 0 : REAL*8 :: SMP_XPN_B(HcoState%NX)
2297 :
2298 : ! [mm H2O] Saturated soil matric potential (sand-dependent)
2299 0 : REAL*8 :: SMP_SAT(HcoState%NX)
2300 :
2301 : !=================================================================
2302 : ! HYD_PRP_GET begins here
2303 : !=================================================================
2304 :
2305 : ! Initialize output values
2306 0 : VWC_DRY(:) = 0.0D0
2307 0 : VWC_OPT(:) = 0.0D0
2308 0 : VWC_SAT(:) = 0.0D0
2309 :
2310 : ! Time-invariant soil hydraulic properties
2311 : ! See Bon96 p. 98, implemented in CCM:lsm/lsmtci()
2312 0 : DO LON_IDX = 1, HcoState%NX
2313 :
2314 0 : IF ( FLG_MBL(LON_IDX) ) THEN
2315 :
2316 : ! Exponent "b" for smp (clay-dependent) [fraction]
2317 : SMP_XPN_B(LON_IDX) =
2318 0 : & 2.91D0 +0.159D0 * MSS_FRC_CLY_SLC(LON_IDX) * 100.0D0
2319 :
2320 : ! NB: Adopt convention that matric potential is positive definite
2321 : ! Saturated soil matric potential (sand-dependent) [mm H2O]
2322 : SMP_SAT(LON_IDX) =
2323 : & 10.0D0 * (10.0D0**(1.88D0-0.0131D0
2324 0 : & * MSS_FRC_SND_SLC(LON_IDX)*100.0D0))
2325 :
2326 : ! Saturated volumetric water content (sand-dependent) ! [m3 m-3]
2327 : VWC_SAT(LON_IDX)=
2328 0 : & 0.489D0 - 0.00126D0 * MSS_FRC_SND_SLC(LON_IDX)*100.0D0
2329 :
2330 : ! [m3 m-3]
2331 : VWC_DRY(LON_IDX) =
2332 :
2333 : ! Dry volumetric water content (no E-T)
2334 : & VWC_SAT(LON_IDX)*(316230.0D0/SMP_SAT(LON_IDX))
2335 0 : & **(-1.0D0/SMP_XPN_B(LON_IDX))
2336 :
2337 : ! E-T optimal volumetric water content! [m3 m-3]
2338 : VWC_OPT(LON_IDX) =
2339 : & VWC_SAT(LON_IDX)*(158490.0D0/SMP_SAT(LON_IDX))
2340 0 : & **(-1.0D0/SMP_XPN_B(LON_IDX))
2341 : ENDIF
2342 : ENDDO
2343 :
2344 : ! Return to calling program
2345 0 : END SUBROUTINE HYD_PRP_GET
2346 :
2347 : !------------------------------------------------------------------------------
2348 :
2349 : SUBROUTINE CND_TRM_SOI_GET( HcoState,CND_TRM_SOI,FLG_MBL,LVL_DLT,
2350 : & MSS_FRC_CLY_SLC, MSS_FRC_SND_SLC,
2351 : & TPT_SOI,
2352 : & VWC_DRY, VWC_OPT, VWC_SAT,
2353 : & VWC_SFC )
2354 :
2355 : !
2356 : !******************************************************************************
2357 : ! Subroutine CND_TRM_SOI_GET gets thermal properties of soil. Currently this
2358 : ! routine is optimized for ground without snow-cover. Although snow
2359 : ! thickness is read in, it is not currently used. (tdf, bmy, 3/30/04)
2360 : !
2361 : ! Arguments as Input:
2362 : ! ============================================================================
2363 : ! (3 ) lvl_dlt (REAL*8 ) : Soil layer thickness [m ]
2364 : ! (4 ) mss_frc_cly (REAL*8 ) : Mass fraction clay [frac.]
2365 : ! (5 ) mss_frc_snd (REAL*8 ) : Mass fraction sand [frac.]
2366 : ! (6 ) tpt_soi (REAL*8 ) : Soil temperature [K ]
2367 : ! (7 ) vwc_dry (REAL*8 ) : Dry volumetric water content (no E-T) [m3/m3]
2368 : ! (8 ) vwc_opt (REAL*8 ) : E-T optimal volumetric water content [m3/m3]
2369 : ! (9 ) vwc_sat (REAL*8 ) : Saturated volumetric water content [m3/m3]
2370 : ! (10) vwc_sfc (REAL*8 ) : Volumetric water content [m3/m3]
2371 : !
2372 : ! Arguments as Output:
2373 : ! ============================================================================
2374 : ! (1 ) CND_TRM_SOI (REAL*8 ) : Soil thermal conductivity [W/m/K]
2375 : ! (2 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [flag ]
2376 : !
2377 : ! NOTES:
2378 : !******************************************************************************
2379 : !
2380 :
2381 : ! Arguments
2382 : TYPE(HCO_State), POINTER :: HcoState
2383 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
2384 : REAL*8, INTENT(IN) :: MSS_FRC_CLY_SLC(HcoState%NX)
2385 : REAL*8, INTENT(IN) :: MSS_FRC_SND_SLC(HcoState%NX)
2386 : REAL*8, INTENT(IN) :: TPT_SOI(HcoState%NX)
2387 : REAL*8, INTENT(IN) :: VWC_DRY(HcoState%NX)
2388 : REAL*8, INTENT(IN) :: VWC_OPT(HcoState%NX)
2389 : REAL*8, INTENT(IN) :: VWC_SAT(HcoState%NX)
2390 : REAL*8, INTENT(IN) :: VWC_SFC(HcoState%NX)
2391 : REAL*8, INTENT(OUT) :: CND_TRM_SOI(HcoState%NX)
2392 : REAL*8, INTENT(OUT) :: LVL_DLT(HcoState%NX)
2393 :
2394 : !------------
2395 : ! Parameters
2396 : !------------
2397 :
2398 : ! Thermal conductivity of ice water [W m-1 K-1]
2399 : REAL*8, PARAMETER :: CND_TRM_H2O_ICE = 2.2d0
2400 :
2401 : ! Thermal conductivity of liquid water [W m-1 K-1]
2402 : REAL*8, PARAMETER :: CND_TRM_H2O_LQD = 0.6d0
2403 :
2404 : ! Thermal conductivity of snow Bon96 p. 77 [W m-1 K-1]
2405 : REAL*8, PARAMETER :: CND_TRM_SNW = 0.34d0
2406 :
2407 : ! Soil layer thickness, top layer! [m]
2408 : REAL*8, PARAMETER :: LVL_DLT_SFC = 0.1d0
2409 :
2410 : ! Temperature range of mixed phase soil [K]
2411 : REAL*8, PARAMETER :: TPT_DLT = 0.5d0
2412 :
2413 : ! Latent heat of fusion of H2O at 0 C, standard [J kg-1]
2414 : REAL*8, PARAMETER :: LTN_HEAT_FSN_H2O_STD = 0.3336d06
2415 :
2416 : ! Liquid water density [kg/m3]
2417 : REAL*8, PARAMETER :: DNS_H2O_LQD_STD = 1000.0d0
2418 :
2419 : ! Kelvin--Celsius scale offset Bol80 [K]
2420 : REAL*8, PARAMETER :: TPT_FRZ_PNT = 273.15d0
2421 :
2422 : !-----------------
2423 : ! Local variables
2424 : !-----------------
2425 :
2426 : ! Longitude index
2427 : INTEGER :: LON_IDX
2428 :
2429 : ! Thermal conductivity of dry soil [W m-1 K-1]
2430 : REAL*8 :: CND_TRM_SOI_DRY(HcoState%NX)
2431 :
2432 : ! Soil thermal conductivity, frozen [W m-1 K-1]
2433 : REAL*8 :: CND_TRM_SOI_FRZ(HcoState%NX)
2434 :
2435 : ! Thermal conductivity of soil solids [W m-1 K-1]
2436 : REAL*8 :: CND_TRM_SOI_SLD(HcoState%NX)
2437 :
2438 : ! Soil thermal conductivity, unfrozen [W m-1 K-1]
2439 : REAL*8 :: CND_TRM_SOI_WRM(HcoState%NX)
2440 :
2441 : ! Volumetric latent heat of fusion [J m-3]
2442 : REAL*8 :: LTN_HEAT_FSN_VLM(HcoState%NX)
2443 :
2444 : ! Bounded geometric bulk thickness of snow [m]
2445 : REAL*8 :: SNW_HGT_BND
2446 :
2447 : !=================================================================
2448 : ! CND_TRM_SOI_GET begins here!
2449 : !=================================================================
2450 :
2451 : ! [m] Soil layer thickness
2452 : LVL_DLT(:) = LVL_DLT_SFC
2453 :
2454 : ! [W m-1 K-1] Soil thermal conductivity
2455 : CND_TRM_SOI(:) = 0.0D0
2456 :
2457 : ! Loop over longitude
2458 : DO LON_IDX = 1, HcoState%NX
2459 : IF ( FLG_MBL(LON_IDX) ) THEN
2460 :
2461 : ! Volumetric latent heat of fusion [J m-3]
2462 : LTN_HEAT_FSN_VLM(LON_IDX) = VWC_SFC(LON_IDX)
2463 : & * LTN_HEAT_FSN_H2O_STD * DNS_H2O_LQD_STD
2464 :
2465 : !Thermal conductivity of soil solids Bon96 p. 77 [W/m/K]
2466 : CND_TRM_SOI_SLD(LON_IDX) =
2467 : & ( 8.80D0 *MSS_FRC_SND_SLC(LON_IDX)
2468 : & + 2.92D0 *MSS_FRC_CLY_SLC(LON_IDX) )
2469 : & / (MSS_FRC_SND_SLC(LON_IDX)
2470 : & + MSS_FRC_CLY_SLC(LON_IDX))
2471 :
2472 : ! Thermal conductivity of dry soil Bon96 p. 77 [W/m/K]
2473 : cnd_trm_soi_dry(lon_idx) = 0.15D0
2474 :
2475 : ! Soil thermal conductivity, unfrozen [W/m/K]
2476 : CND_TRM_SOI_WRM(LON_IDX) =
2477 : & CND_TRM_SOI_DRY(LON_IDX)
2478 : & + ( CND_TRM_SOI_SLD(LON_IDX)
2479 : & ** (1.0D0-VWC_SAT(LON_IDX))
2480 : & * (CND_TRM_H2O_LQD ** VWC_SFC(LON_IDX) )
2481 : & - CND_TRM_SOI_DRY(LON_IDX) )
2482 : & * VWC_SFC(LON_IDX) / VWC_SAT(lon_idx)
2483 :
2484 : ! Soil thermal conductivity, frozen [W/m/K]
2485 : CND_TRM_SOI_FRZ(LON_IDX) =
2486 : & CND_TRM_SOI_DRY(LON_IDX)
2487 : & + ( CND_TRM_SOI_SLD(LON_IDX)
2488 : & ** (1.0D0-VWC_SAT(LON_IDX))
2489 : & * (CND_TRM_H2O_ICE ** VWC_SFC(LON_IDX) )
2490 : & - CND_TRM_SOI_DRY(LON_IDX) )
2491 : & * VWC_SFC(LON_IDX) / VWC_SAT(LON_IDX)
2492 :
2493 : IF (TPT_SOI(LON_IDX) < TPT_FRZ_PNT-TPT_DLT) THEN
2494 : ! Soil thermal conductivity [W/m/K]
2495 : CND_TRM_SOI(LON_IDX) = CND_TRM_SOI_FRZ(LON_IDX)
2496 : ENDIF
2497 :
2498 : IF ( (TPT_SOI(LON_IDX) >= TPT_FRZ_PNT-TPT_DLT)
2499 : & .AND. (TPT_SOI(LON_IDX) <= TPT_FRZ_PNT+TPT_DLT) )
2500 : & THEN
2501 :
2502 : ! Soil thermal conductivity [W/m/K]
2503 : CND_TRM_SOI(LON_IDX) =
2504 : & CND_TRM_SOI_FRZ(LON_IDX)
2505 : & + (CND_TRM_SOI_FRZ(LON_IDX)
2506 : & - CND_TRM_SOI_WRM(LON_IDX) )
2507 : & * (TPT_SOI(LON_IDX)
2508 : & -TPT_FRZ_PNT+TPT_DLT)
2509 : & / (2.0D0*TPT_DLT)
2510 : ENDIF
2511 :
2512 : IF (TPT_SOI(LON_IDX) > TPT_FRZ_PNT+TPT_DLT) THEN
2513 : ! Soil thermal conductivity[W/m/K]
2514 : CND_TRM_SOI(LON_IDX)=CND_TRM_SOI_WRM(LON_IDX)
2515 : ENDIF
2516 :
2517 : ! Implement this later(??)
2518 : !cZ Blend snow into first soil layer
2519 : !cZ Snow is not allowed to cover dust mobilization regions
2520 : !cZ snw_hgt_bnd=min(snw_hgt(lon_idx),1.0D0) ! [m] Bounded geometric bulk thickness of snow
2521 : !cZ lvl_dlt_snw(lon_idx)=lvl_dlt(lon_idx)+snw_hgt_bnd ! O [m] Soil layer thickness
2522 : !cZ including snow Bon96 p. 77
2523 : !
2524 : !cZ cnd_trm_soi(lon_idx)= & ! [W m-1 K-1] Soil thermal conductivity Bon96 p. 77
2525 : !cZ cnd_trm_snw*cnd_trm_soi(lon_idx)*lvl_dlt_snw(lon_idx) &
2526 : !cZ /(cnd_trm_snw*lvl_dlt(lon_idx)+cnd_trm_soi(lon_idx)*snw_hgt_bnd)
2527 :
2528 : ENDIF
2529 : ENDDO
2530 :
2531 : END SUBROUTINE CND_TRM_SOI_GET
2532 :
2533 : !------------------------------------------------------------------------------
2534 :
2535 : SUBROUTINE TRN_FSH_VPR_SOI_ATM_GET( HcoState, FLG_MBL,
2536 : & TPT_SOI,
2537 : & TPT_SOI_FRZ,
2538 : & TRN_FSH_VPR_SOI_ATM,
2539 : & VWC_DRY,
2540 : & VWC_OPT,
2541 : & VWC_SFC )
2542 : !
2543 : !******************************************************************************
2544 : ! Subroutine TRN_FSH_VPR_SOI_ATM_GET computes the factor describing effects
2545 : ! of soil texture and moisture on vapor transfer between soil and atmosphere.
2546 : ! Taken from Bon96 p. 59, CCM:lsm/surphys. (tdf, bmy, 3/30/04)
2547 : !
2548 : ! The TRN_FSH_VPR_SOI_ATM efficiency factor attempts to tie soil texture and
2549 : ! moisture properties to the vapor conductance of the soil-atmosphere system.
2550 : ! When the soil temperature is sub-freezing, the conductance describes the
2551 : ! resistance to vapor sublimation (or deposition) and transport through the
2552 : ! open soil pores to the atmosphere.
2553 : !
2554 : ! For warm soils, vapor transfer is most efficient at the optimal VWC for E-T
2555 : ! Thus when vwc_sfc = vwc_opt, soil vapor transfer is perfectly efficient
2556 : ! (trn_fsh_vpr_soi_atm = 1.0) so the soil does not contribute any resistance
2557 : ! to the surface vapor transfer.
2558 : !
2559 : ! When vwc_sfc > vwc_opt, the soil has an excess of moisture and, again,
2560 : ! vapor transfer is not limited by soil characteristics.
2561 : ! In fact, according to Bon96 p. 98, vwc_dry is only slightly smaller than
2562 : ! vwc_opt, so trn_fsh_vpr_soi_atm is usually either 0 or 1 and intermediate
2563 : ! efficiencies occur over only a relatively small range of VWC.
2564 : !
2565 : ! When vwc_sfc < vwc_dry, the soil matrix is subsaturated and acts as a
2566 : ! one-way sink for vapor through osmotic and capillary potentials.
2567 : ! In this case trn_fsh_vpr_soi_atm = 0, which would cause the surface
2568 : ! resistance rss_vpr_sfc to blow up, but this is guarded against and
2569 : ! rss_sfc_vpr is set to ~1.0e6*rss_aer_vpr instead.
2570 : !
2571 : ! Note that this formulation does not seem to allow vapor transfer from
2572 : ! the atmosphere to the soil when vwc_sfc < vwc_dry, even when
2573 : ! e_atm > esat(Tg).
2574 : !
2575 : ! Air at the apparent sink for moisture is has vapor pressure e_sfc
2576 : ! e_atm = Vapor pressure of ambient air at z = hgt_mdp
2577 : ! e_sfc = Vapor pressure at apparent sink for moisture at z = zpd + rgh_vpr
2578 : ! e_gnd = Vapor pressure at air/ground interface temperature
2579 : ! Air at the soil interface is assumed saturated, i.e., e_gnd = esat(Tg)
2580 : !
2581 : ! Arguments as Input:
2582 : ! ============================================================================
2583 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [unitless]
2584 : ! (2 ) TPT_SOI (REAL*8 ) : Soil temperature [K ]
2585 : ! (3 ) TPT_SOI_FRZ (REAL*8 ) : Temperature of frozen soil [K ]
2586 : ! (5 ) VWC_DRY (REAL*8 ) : Dry volumetric WC (no E-T) [m3/m3 ]
2587 : ! (6 ) VWC_OPT (REAL*8 ) : E-T optimal volumetric WC [m3/m3 ]
2588 : ! (7 ) VWC_SFC (REAL*8 ) : Volumetric water content [m3/m3 ]
2589 : !
2590 : ! Arguments as Output:
2591 : ! ============================================================================
2592 : ! (4 ) TRN_FSH_VPR_SOI_ATM (REAL*8 ) : Transfer efficiency of vapor from
2593 : ! soil to atmosphere [fraction]
2594 : !
2595 : ! NOTES:
2596 : ! (1 ) Updated comments, cosmetic changes. Also force double-precision
2597 : ! with "D" exponents. (tdf, bmy, 3/30/04)
2598 : !******************************************************************************
2599 : !
2600 :
2601 : !----------------
2602 : ! Arguments
2603 : !----------------
2604 : TYPE(HCO_State), POINTER :: HCoState
2605 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
2606 : REAL*8, INTENT(IN) :: TPT_SOI(HcoState%NX)
2607 : REAL*8, INTENT(IN) :: TPT_SOI_FRZ
2608 : REAL*8, INTENT(IN) :: VWC_DRY(HcoState%NX)
2609 : REAL*8, INTENT(IN) :: VWC_OPT(HcoState%NX)
2610 : REAL*8, INTENT(IN) :: VWC_SFC(HcoState%NX)
2611 : REAL*8, INTENT(OUT) :: TRN_FSH_VPR_SOI_ATM(HcoState%NX)
2612 :
2613 : !----------------
2614 : ! Parameters
2615 : !----------------
2616 :
2617 : ! Transfer efficiency of vapor from frozen soil to
2618 : ! atmosphere CCM:lsm/surphy() [fraction]
2619 : REAL*8, PARAMETER :: TRN_FSH_VPR_SOI_ATM_FRZ = 0.01D0
2620 :
2621 : !-----------------
2622 : ! Local variables
2623 : !-----------------
2624 : INTEGER :: LON_IDX
2625 :
2626 : !=================================================================
2627 : ! TRN_FSH_VPR_SOI_ATM_GET
2628 : !=================================================================
2629 : TRN_FSH_VPR_SOI_ATM(:) = 0.0D0
2630 :
2631 : ! Loop over longitudes
2632 : DO LON_IDX = 1, HcoState%NX
2633 :
2634 : ! If this is a mobilization candidate ...
2635 : IF ( FLG_MBL(LON_IDX) ) THEN
2636 :
2637 : ! ... and if the soil is above freezing ...
2638 : IF ( TPT_SOI(LON_IDX) > TPT_SOI_FRZ ) THEN
2639 :
2640 : ! Transfer efficiency of cvapor from soil to atmosphere [frac]
2641 : ! CCM:lsm/surphys Bon96 p. 59
2642 : TRN_FSH_VPR_SOI_ATM(LON_IDX) =
2643 : & MIN ( MAX(VWC_SFC(LON_IDX)-VWC_DRY(LON_IDX), 0.0D0)
2644 : & /(VWC_OPT(LON_IDX)-VWC_DRY(LON_IDX)), 1.0D0)
2645 :
2646 : ELSE
2647 :
2648 : ! [frc] Bon96 p. 59
2649 : TRN_FSH_VPR_SOI_ATM(LON_IDX) = TRN_FSH_VPR_SOI_ATM_FRZ
2650 :
2651 : ENDIF
2652 : ENDIF
2653 : ENDDO
2654 :
2655 : ! Return to calling program
2656 : END SUBROUTINE TRN_FSH_VPR_SOI_ATM_GET
2657 :
2658 : !------------------------------------------------------------------------------
2659 :
2660 0 : SUBROUTINE BLM_MBL( HcoState, FLG_MBL, RGH_MMN,
2661 0 : & WND_10M, MNO_LNG, WND_FRC, RC )
2662 : !
2663 : !******************************************************************************
2664 : ! Subroutine BLM_MBL computes the boundary-layer exchange properties, given
2665 : ! the meteorology at the GEOS-CHEM layer midpoint. This routine is optimized
2666 : ! for dust source regions: dry, bare, uncovered land. Theory and algorithms:
2667 : ! Bonan (1996) CCM:lsm/surtem(). Stripped down version, based on adiabatic
2668 : ! approximation to U*. (tdf, bmy, 3/30/04)
2669 : !
2670 : ! Arguments as Input:
2671 : ! ============================================================================
2672 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [unitless]
2673 : ! (2 ) RGH_MMN (REAL*8 ) : Roughness length momentum [m ]
2674 : ! (3 ) WND_10M (REAL*8 ) : 10 m wind speed [m/s ]
2675 : !
2676 : ! Arguments as Output:
2677 : ! ============================================================================
2678 : ! (4 ) MNO_LNG (REAL*8 ) : Monin-Obukhov length [m ]
2679 : ! (5 ) WND_FRC (REAL*8 ) : Surface friction velocity [m/s ]
2680 : !
2681 : ! NOTES:
2682 : ! (1 ) Updated comments, cosmetic changes. Also force double-precision with
2683 : ! "D" exponents. (tdf, bmy, 3/30/04)
2684 : !******************************************************************************
2685 : !
2686 : !-----------------
2687 : ! Arguments
2688 : !-----------------
2689 : TYPE(HCO_State), POINTER :: HcoState
2690 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
2691 : REAL*8, INTENT(IN) :: RGH_MMN(HcoState%NX)
2692 : REAL*8, INTENT(IN) :: WND_10M(HcoState%NX)
2693 : REAL*8, INTENT(OUT) :: MNO_LNG(HcoState%NX)
2694 : REAL*8, INTENT(OUT) :: WND_FRC(HcoState%NX)
2695 : INTEGER, INTENT(INOUT) :: RC
2696 :
2697 : !-----------------
2698 : ! Parameters
2699 : !-----------------
2700 :
2701 : ! Prevents division by zero [unitless]
2702 : REAL*8, PARAMETER :: EPS_DBZ = 1.0d-6
2703 :
2704 : ! Minimum windspeed used for mobilization [m/s]
2705 : REAL*8, PARAMETER :: WND_MIN_MBL = 1.0d0
2706 :
2707 : ! Roughness length momentum for erodible surfaces [m]
2708 : ! MaB95 p. 16420, GMB98 p. 6205
2709 : REAL*8, PARAMETER :: RGH_MMN_MBL = 100.0d-6
2710 :
2711 : ! Reference height for mobilization processes [m]
2712 : REAL*8, PARAMETER :: HGT_RFR = 10.0d0
2713 :
2714 : !-----------------
2715 : ! Local variables
2716 : !-----------------
2717 :
2718 : ! Counting index for lon
2719 : INTEGER :: LON_IDX
2720 :
2721 : ! Denominator of Monin-Obukhov length Bon96 p. 49
2722 : REAL*8 :: MNO_DNM
2723 :
2724 : ! Surface layer mean wind speed [m/s]
2725 0 : REAL*8 :: WND_MDP_BND(HcoState%NX)
2726 :
2727 : ! denominator for wind friction velocity
2728 : REAL*8 :: WND_FRC_DENOM
2729 :
2730 : ! For error handling
2731 : CHARACTER(LEN=255) :: MSG
2732 :
2733 : !=================================================================
2734 : ! BLM_MBL begins here!
2735 : !=================================================================
2736 :
2737 : ! Initialize
2738 0 : MNO_LNG(:) = 0.0D0
2739 0 : WND_FRC(:) = 0.0D0
2740 :
2741 : ! Loop over longitudes
2742 0 : DO LON_IDX = 1, HcoState%NX
2743 :
2744 : ! Surface layer mean wind speed bounded [m/s]
2745 0 : WND_MDP_BND(LON_IDX) =
2746 0 : & MAX(WND_10M(LON_IDX), WND_MIN_MBL)
2747 :
2748 : ! Friction velocity (adiabatic approximation S&P equ. 16.57,
2749 : ! tdf 10/27/2K3 -- Sanity check
2750 0 : IF ( RGH_MMN(LON_IDX) <= 0.0 ) THEN
2751 0 : MSG = 'RGH_MMN <= 0.0'
2752 0 : CALL HCO_ERROR(MSG,RC,THISLOC='BLM_MBL')
2753 0 : RETURN
2754 : ENDIF
2755 :
2756 : ! Distinguish between mobilisation candidates and noncandidates
2757 0 : IF ( FLG_MBL(LON_IDX) ) THEN
2758 : WND_FRC_DENOM = HGT_RFR / RGH_MMN_MBL ! z = 10 m
2759 : ELSE
2760 0 : WND_FRC_DENOM = HGT_RFR / RGH_MMN(LON_IDX) ! z = 10 m
2761 : ENDIF
2762 :
2763 : ! Sanity check
2764 0 : IF ( WND_FRC_DENOM <= 0.0 ) THEN
2765 0 : MSG = 'WND_FRC_DENOM <= 0.0'
2766 0 : CALL HCO_ERROR(MSG,RC,THISLOC='BLM_MBL')
2767 0 : RETURN
2768 : ENDIF
2769 :
2770 : ! Take natural LOG of WND_FRC_DENOM
2771 0 : WND_FRC_DENOM = LOG(WND_FRC_DENOM)
2772 :
2773 : ! Convert to [m/s]
2774 : WND_FRC(LON_IDX) = WND_MDP_BND(LON_IDX) * CST_VON_KRM
2775 0 : & / WND_FRC_DENOM
2776 :
2777 : ! Denominator of Monin-Obukhov length Bon96 p. 49
2778 : ! Set denominator of Monin-Obukhov length to minimum value
2779 0 : MNO_DNM = EPS_DBZ
2780 :
2781 : ! Monin-Obukhov length Bon96 p. 49 [m]
2782 : MNO_LNG(LON_IDX) = -1.0D0 * (WND_FRC(LON_IDX)**3.0D0)
2783 0 : & /MNO_DNM
2784 :
2785 : ! Override for non mobilisation candidates
2786 0 : IF ( .NOT. FLG_MBL(LON_IDX) ) THEN
2787 0 : WND_FRC(LON_IDX) = 0.0D0
2788 : ENDIF
2789 : ENDDO
2790 :
2791 : ! Return w/ success
2792 0 : RC = HCO_SUCCESS
2793 :
2794 : END SUBROUTINE BLM_MBL
2795 :
2796 : !------------------------------------------------------------------------------
2797 :
2798 0 : LOGICAL FUNCTION ORO_IS_OCN( ORO_VAL )
2799 : !
2800 : !******************************************************************************
2801 : ! Function ORO_IS_OCN returns TRUE if a grid box contains more than 50%
2802 : ! ocean. (tdf, bmy, 3/30/04)
2803 : !
2804 : ! Arguments as Input:
2805 : ! ============================================================================
2806 : ! (1 ) ORO_VAL (REAL*8) : Orography at a grid box (0=ocean; 1=land; 2=ice)
2807 : !
2808 : ! NOTES:
2809 : !******************************************************************************
2810 : !
2811 : ! Arguments
2812 : REAL*8, INTENT(IN) :: ORO_VAL
2813 :
2814 : !=================================================================
2815 : ! ORO_IS_OCN begins here!
2816 : !=================================================================
2817 0 : ORO_IS_OCN = ( NINT( ORO_VAL ) == 0 )
2818 :
2819 : ! Return to calling program
2820 0 : END FUNCTION ORO_IS_OCN
2821 :
2822 : !------------------------------------------------------------------------------
2823 :
2824 0 : LOGICAL FUNCTION ORO_IS_LND( ORO_VAL )
2825 : !
2826 : !******************************************************************************
2827 : ! Function ORO_IS_LND returns TRUE if a grid box contains more than 50%
2828 : ! land. (tdf, bmy, 3/30/04, 3/1/05)
2829 : !
2830 : ! Arguments as Input:
2831 : ! ============================================================================
2832 : ! (1 ) ORO_VAL (REAL*8) : Orography at a grid box (0=ocean; 1=land; 2=ice)
2833 : !
2834 : ! NOTES:
2835 : ! (1 ) Bug fix: Replaced ": :" with "::" in order to prevent compile error
2836 : ! on Linux w/ PGI compiler. (bmy, 3/1/05)
2837 : !******************************************************************************
2838 : !
2839 : ! Arguments
2840 : REAL*8, INTENT(IN) :: ORO_VAL
2841 :
2842 : !=================================================================
2843 : ! ORO_IS_OCN begins here!
2844 : !=================================================================
2845 0 : ORO_IS_LND = ( NINT( ORO_VAL ) == 1 )
2846 :
2847 : ! Return to calling program
2848 0 : END FUNCTION ORO_IS_LND
2849 :
2850 : !------------------------------------------------------------------------------
2851 :
2852 0 : LOGICAL FUNCTION ORO_IS_ICE( ORO_VAL )
2853 : !
2854 : !******************************************************************************
2855 : ! Function ORO_IS_LND returns TRUE if a grid box contains more than 50%
2856 : ! ice. (tdf, bmy, 3/30/04)
2857 : !
2858 : ! Arguments as Input:
2859 : ! ============================================================================
2860 : ! (1 ) ORO_VAL (REAL*8) : Orography at a grid box (0=ocean; 1=land; 2=ice)
2861 : !
2862 : ! NOTES:
2863 : !******************************************************************************
2864 : !
2865 : ! Arguments
2866 : REAL*8, INTENT(IN) :: ORO_VAL
2867 :
2868 : !=================================================================
2869 : ! ORO_IS_ICE begins here!
2870 : !=================================================================
2871 0 : ORO_IS_ICE = ( NINT( ORO_VAL ) == 2 )
2872 :
2873 : ! Return to calling program
2874 0 : END FUNCTION ORO_IS_ICE
2875 :
2876 : !------------------------------------------------------------------------------
2877 :
2878 : REAL*8 FUNCTION MNO_STB_CRC_HEAT_UNS_GET( SML_FNC_MMN_UNS_RCP )
2879 : !
2880 : !******************************************************************************
2881 : ! Function MNO_STB_CRC_HEAT_UNS_GET returns the stability correction factor
2882 : ! for heat (usually called PSI), given the reciprocal of the Monin-Obukhov
2883 : ! similarity function (usually called PHI) for momentum in an unstable
2884 : ! atmosphere. (tdf, bmy, 3/30/04)
2885 : !
2886 : ! Arguments as Input:
2887 : ! ============================================================================
2888 : ! (1 ) sml_fnc_mmn_uns_rcp (REAL*8) : 1/(M-O similarity function) [fraction]
2889 : !
2890 : ! References:
2891 : ! ============================================================================
2892 : ! References are Ary88 p. 167, Bru82 p. 71, SeP97 p. 869,
2893 : ! Bon96 p. 52, BKL97 p. F1, LaP81 p. 325, LaP82 p. 466
2894 : ! Currently this function is BFB with CCM:dom/flxoce()
2895 : !
2896 : ! NOTES:
2897 : ! (1 ) Updated comments, cosmetic changes (bmy, 3/30/04)
2898 : !******************************************************************************
2899 : !
2900 : ! Arguments
2901 : REAL*8, INTENT(IN) :: SML_FNC_MMN_UNS_RCP
2902 :
2903 : !=================================================================
2904 : ! MNO_STB_CRC_HEAT_UNS_GET
2905 : !=================================================================
2906 : MNO_STB_CRC_HEAT_UNS_GET = 2.0D0 *
2907 : & LOG( ( 1.0D0+SML_FNC_MMN_UNS_RCP * SML_FNC_MMN_UNS_RCP) / 2.0D0 )
2908 :
2909 : ! Return to calling program
2910 : END FUNCTION MNO_STB_CRC_HEAT_UNS_GET
2911 :
2912 : !------------------------------------------------------------------------------
2913 :
2914 : REAL*8 FUNCTION MNO_STB_CRC_MMN_UNS_GET( SML_FNC_MMN_UNS_RCP )
2915 : !
2916 : !******************************************************************************
2917 : ! Function MNO_STB_CRC_MMN_UNS_GET returns the stability correction factor
2918 : ! for momentum (usually called PSI), given the reciprocal of the
2919 : ! Monin-Obukhov similarity function (usually called PHI), for momentum in
2920 : ! an unstable atmosphere. (tdf, bmy, 3/30/04)
2921 : !
2922 : ! Arguments as Input:
2923 : ! ============================================================================
2924 : ! (1 ) SML_FNC_MMN_UNS_RCP (REAL*8) : 1/(M-O similarity function) [fraction]
2925 : !
2926 : ! References:
2927 : ! ============================================================================
2928 : ! References are Ary88 p. 167, Bru82 p. 71, SeP97 p. 869,
2929 : ! Bon96 p. 52, BKL97 p. F1, LaP81 p. 325, LaP82 p. 466
2930 : ! Currently this function is BFB with CCM:dom/flxoce()
2931 : !
2932 : ! NOTES:
2933 : ! (1 ) Updated comments, cosmetic changes (bmy, 3/30/04)
2934 : !******************************************************************************
2935 : !
2936 : ! Arguments
2937 : REAL*8, INTENT(IN) :: SML_FNC_MMN_UNS_RCP
2938 :
2939 : !=================================================================
2940 : ! MNO_STB_CRC_MMN_UNS_GET begins here!
2941 : !=================================================================
2942 : MNO_STB_CRC_MMN_UNS_GET =
2943 : & LOG((1.0D0+SML_FNC_MMN_UNS_RCP*(2.0D0+SML_FNC_MMN_UNS_RCP))
2944 : & *(1.0D0+SML_FNC_MMN_UNS_RCP*SML_FNC_MMN_UNS_RCP)/8.0D0)
2945 : & -2.0D0*ATAN(SML_FNC_MMN_UNS_RCP)+1.571D0
2946 :
2947 : ! Return to calling program
2948 : END FUNCTION MNO_STB_CRC_MMN_UNS_GET
2949 :
2950 : !------------------------------------------------------------------------------
2951 :
2952 0 : REAL*8 FUNCTION XCH_CFF_MMN_OCN_NTR_GET( WND_10M_NTR )
2953 : !
2954 : !******************************************************************************
2955 : ! Function XCH_CFF_MMN_OCN_NTR_GET returns the Neutral 10m drag coefficient
2956 : ! over oceans. (tdf, bmy, 3/30/04)
2957 : !
2958 : ! Arguments as Input:
2959 : ! ============================================================================
2960 : ! (1 ) WIND_10M_NTR (REAL*8) : Wind speed @ 10 m[m/s]
2961 : !
2962 : ! References:
2963 : ! ============================================================================
2964 : ! LaP82 CCM:dom/flxoce(), NOS97 p. I2
2965 : !
2966 : ! NOTES:
2967 : ! (1 ) Updated comments, cosmetic changes (bmy, 3/30/04)
2968 : !******************************************************************************
2969 : !
2970 : ! Arguments
2971 : REAL*8, INTENT(IN) :: WND_10M_NTR
2972 :
2973 : !=================================================================
2974 : ! XCH_CFF_MMN_OCN_NTR_GET begins here!
2975 : !=================================================================
2976 : XCH_CFF_MMN_OCN_NTR_GET = 0.0027D0 / WND_10M_NTR + 0.000142D0
2977 0 : & + 0.0000764D0 * WND_10M_NTR
2978 :
2979 : ! REturn to calling program
2980 0 : END FUNCTION XCH_CFF_MMN_OCN_NTR_GET
2981 :
2982 : !------------------------------------------------------------------------------
2983 :
2984 0 : SUBROUTINE RGH_MMN_GET( HcoState,Inst,ORO, RGH_MMN,
2985 0 : & SFC_TYP_SLC, SNW_FRC, WND_10M, RC )
2986 : !
2987 : !******************************************************************************
2988 : ! Subroutine RGH_MMN_GET sets the roughness length. (tdf, bmy, 3/30/04)
2989 : !
2990 : ! Arguments as Input:
2991 : ! ============================================================================
2992 : ! (1 ) ORO (INTEGER) : Orography (0=ocean; 1=land; 2=ice) [unitless]
2993 : ! (3 ) SFC_TYP (REAL*8 ) : LSM surface type (0..28) [unitless]
2994 : ! (4 ) SNW_FRC (REAL*8 ) : Fraction of surface covered by snow [fraction]
2995 : ! (5 ) WND_10M (REAL*8 ) : 10 m wind speed [m/s ]
2996 : !
2997 : ! Arguments as Output:
2998 : ! ============================================================================
2999 : ! (2 ) RGH_MMN (REAL*8 ) : Roughness length momentu [m ]
3000 : !
3001 : ! NOTES:
3002 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
3003 : ! with "D" exponents (bmy, 3/30/04)
3004 : !******************************************************************************
3005 : !
3006 :
3007 : !-----------------
3008 : ! Arguments
3009 : !-----------------
3010 : TYPE(HCO_State), POINTER :: HcoState
3011 : TYPE(MyInst), POINTER :: Inst
3012 : INTEGER, INTENT(IN) :: SFC_TYP_SLC(HcoState%NX)
3013 : REAL*8, INTENT(IN) :: ORO(HcoState%NX)
3014 : REAL*8, INTENT(IN) :: SNW_FRC(HcoState%NX)
3015 : REAL*8, INTENT(IN) :: WND_10M(HcoState%NX)
3016 : REAL*8, INTENT(OUT) :: RGH_MMN(HcoState%NX)
3017 : INTEGER, INTENT(INOUT) :: RC
3018 :
3019 : !-----------------
3020 : ! Parameters
3021 : !-----------------
3022 :
3023 : ! Roughness length over frozen lakes Bon96 p. 59 [m]
3024 : REAL*8, PARAMETER :: RGH_MMN_ICE_LAK = 0.04d0
3025 :
3026 : ! Roughness length over ice, bare ground, wetlands Bon96 p. 59 [m]
3027 : REAL*8, PARAMETER :: RGH_MMN_ICE_LND = 0.05d0
3028 :
3029 : ! Roughness length over sea ice BKL97 p. F-3 [m]
3030 : REAL*8, PARAMETER :: RGH_MMN_ICE_OCN = 0.0005d0
3031 :
3032 : ! Roughness length over unfrozen lakes Bon96 p. 59 [m]
3033 : REAL*8, PARAMETER :: RGH_MMN_LAK_WRM = 0.001d0
3034 :
3035 : ! Roughness length over snow Bon96 p. 59 CCM:lsm/snoconi.F ! [m]
3036 : REAL*8, PARAMETER :: RGH_MMN_SNW = 0.04d0
3037 :
3038 : ! Minimum windspeed for momentum exchange
3039 : REAL*8, PARAMETER :: WND_MIN_DPS = 1.0d0
3040 :
3041 : !-----------------
3042 : ! Local variables
3043 : !-----------------
3044 :
3045 : ! [idx] Longitude index array (sea ice)
3046 0 : INTEGER :: ICE_IDX(HcoState%NX)
3047 :
3048 : ! [nbr] Number of sea ice points
3049 : INTEGER :: ICE_NBR
3050 :
3051 : ! [Idx] Counting index
3052 : INTEGER :: IDX_IDX
3053 :
3054 : ! [idx] Longitude index array (land)
3055 0 : INTEGER :: LND_IDX(HcoState%NX)
3056 :
3057 : ! [nbr] Number of land points
3058 : INTEGER :: LND_NBR
3059 :
3060 : ! [idx] Counting index
3061 : INTEGER :: LON_IDX
3062 :
3063 : ! [idx] Longitude index array (ocean)
3064 0 : INTEGER :: OCN_IDX(HcoState%NX)
3065 :
3066 : ! [nbr] Number of ocean points
3067 : INTEGER :: OCN_NBR
3068 :
3069 : ! [idx] Plant type index
3070 : INTEGER :: PLN_TYP_IDX
3071 :
3072 : ! [idx] Surface type index
3073 : INTEGER :: SFC_TYP_IDX
3074 :
3075 : ! [idx] Surface sub-gridscale index
3076 : INTEGER :: SGS_IDX
3077 :
3078 : ! [m] Roughness length of current sub-gridscale
3079 : REAL*8 :: RLM_CRR
3080 :
3081 : ! [m s-1] Bounded wind speed at 10 m
3082 : REAL*8 :: WND_10M_BND
3083 :
3084 : ! [frc] Neutral 10 m drag coefficient over ocean
3085 : REAL*8 :: XCH_CFF_MMN_OCN_NTR
3086 :
3087 : ! Momentum roughness length [m]
3088 : REAL*8 :: Z0MVT(MVT) = (/ 0.94d0, 0.77d0, 2.62d0, 1.10d0, 0.99d0,
3089 : & 0.06d0, 0.06d0, 0.06d0, 0.06d0, 0.06d0,
3090 : & 0.06d0, 0.06d0, 0.06d0, 0.00d0 /)
3091 :
3092 : ! Displacement height (fn of plant type)
3093 : REAL*8 :: ZPDVT(MVT) = (/ 11.39d0, 9.38d0, 23.45d0, 13.40d0,
3094 : & 12.06d0, 0.34d0, 0.34d0, 0.34d0,
3095 : & 0.34d0, 0.34d0, 0.34d0, 0.34d0,
3096 : & 0.34d0, 0.00d0 /)
3097 :
3098 : !=================================================================
3099 : ! RGH_MMN_GET begins here
3100 : !=================================================================
3101 0 : RGH_MMN(:) = 0.0D0
3102 :
3103 : ! Count ocean grid boxes
3104 0 : OCN_NBR = 0
3105 0 : DO LON_IDX = 1, HcoState%NX
3106 0 : IF ( ORO_IS_OCN( ORO(LON_IDX) ) ) THEN
3107 0 : OCN_NBR = OCN_NBR + 1
3108 0 : OCN_IDX(OCN_NBR) = LON_IDX
3109 : ENDIF
3110 : ENDDO
3111 :
3112 : ! Count ice grid boxes
3113 0 : ICE_NBR = 0
3114 0 : DO LON_IDX = 1, HcoState%NX
3115 0 : IF ( ORO_IS_ICE( ORO(LON_IDX) ) ) THEN
3116 0 : ICE_NBR = ICE_NBR+1
3117 0 : ICE_IDX(ICE_NBR) = LON_IDX
3118 : ENDIF
3119 : ENDDO
3120 :
3121 : ! Count land grid boxes
3122 0 : LND_NBR = 0
3123 0 : DO LON_IDX = 1, HcoState%NX
3124 0 : IF ( ORO_IS_LND( ORO(LON_IDX) ) ) THEN
3125 0 : LND_NBR = LND_NBR + 1
3126 0 : LND_IDX(LND_NBR) = LON_IDX
3127 : ENDIF
3128 : ENDDO
3129 :
3130 : !=================================================================
3131 : ! Ocean points
3132 : !=================================================================
3133 0 : DO IDX_IDX = 1, OCN_NBR
3134 :
3135 : ! Longitude index of the ocean point
3136 0 : LON_IDX = OCN_IDX(IDX_IDX)
3137 :
3138 : ! Convert wind speed to roughness length over ocean [m/s]
3139 0 : WND_10M_BND = MAX( WND_MIN_DPS, WND_10M(LON_IDX) )
3140 :
3141 : !Approximation: neutral 10 m wind speed unavailable,
3142 : ! use 10 m wind speed [fraction]
3143 0 : XCH_CFF_MMN_OCN_NTR = XCH_CFF_MMN_OCN_NTR_GET(WND_10M_BND)
3144 :
3145 : ! BKL97 p. F-4, LaP81 p. 327 (14) Ocean Points [m]
3146 : RGH_MMN(LON_IDX)=10.0D0
3147 0 : & * EXP(-CST_VON_KRM / SQRT(XCH_CFF_MMN_OCN_NTR))
3148 : ENDDO
3149 :
3150 : !=================================================================
3151 : ! Sea ice points
3152 : !=================================================================
3153 0 : DO IDX_IDX = 1, ICE_NBR
3154 0 : LON_IDX = ICE_IDX(IDX_IDX)
3155 0 : RGH_MMN(LON_IDX) = SNW_FRC(LON_IDX) * RGH_MMN_SNW
3156 0 : & +(1.0D0-SNW_FRC(LON_IDX)) * RGH_MMN_ICE_OCN ! [m] Bon96 p. 59
3157 : ENDDO
3158 :
3159 : !=================================================================
3160 : ! Land points
3161 : !=================================================================
3162 0 : DO IDX_IDX = 1, LND_NBR
3163 :
3164 : ! Longitude
3165 0 : LON_IDX = LND_IDX(IDX_IDX)
3166 :
3167 : ! Store surface blend for current gridpoint, sfc_typ(lon_idx)
3168 0 : SFC_TYP_IDX = SFC_TYP_SLC(LON_IDX)
3169 :
3170 : ! Inland lakes
3171 0 : IF ( SFC_TYP_IDX == 0 ) THEN
3172 :
3173 : !fxm: Add temperature input and so ability to discriminate warm
3174 : ! from frozen lakes here [m] Bon96 p. 59
3175 0 : RGH_MMN(LON_IDX) = RGH_MMN_LAK_WRM
3176 :
3177 : ! Land ice
3178 0 : ELSE IF ( SFC_TYP_IDX == 1 ) THEN
3179 :
3180 : ! [m] Bon96 p. 59
3181 : RGH_MMN(LON_IDX) = SNW_FRC(LON_IDX)*RGH_MMN_SNW
3182 0 : & + (1.0D0-SNW_FRC(LON_IDX))*RGH_MMN_ICE_LND
3183 :
3184 :
3185 : ! Normal land
3186 : ELSE
3187 0 : DO SGS_IDX = 1, 3
3188 :
3189 : ! Bare ground is pln_typ=14, ocean is pln_typ=0
3190 0 : PLN_TYP_IDX = Inst%PLN_TYP(SFC_TYP_IDX,SGS_IDX)
3191 :
3192 : ! Bare ground
3193 0 : IF ( PLN_TYP_IDX == 14 ) THEN
3194 :
3195 : ! Bon96 p. 59 (glacial ice is same as bare ground)
3196 : RLM_CRR = SNW_FRC(LON_IDX) * RGH_MMN_SNW
3197 0 : & + (1.0D0-SNW_FRC(LON_IDX)) * RGH_MMN_ICE_LND ! [m]
3198 :
3199 : ! Regular plant type
3200 0 : ELSE IF ( PLN_TYP_IDX > 0 ) THEN
3201 : RLM_CRR = SNW_FRC(LON_IDX) * RGH_MMN_SNW
3202 0 : & + (1.0D0-SNW_FRC(LON_IDX)) * Z0MVT(PLN_TYP_IDX)
3203 : ! [m] Bon96 p. 59
3204 :
3205 : ! Presumably ocean snuck through
3206 : ELSE
3207 : CALL HCO_ERROR(
3208 : & 'pln_typ_idx == 0', RC,
3209 0 : & THISLOC='RGH_MMN_GET' )
3210 : RETURN
3211 : ENDIF ! endif
3212 :
3213 : ! Roughness length for normal land
3214 : RGH_MMN(LON_IDX) = RGH_MMN(LON_IDX) ! [m]
3215 0 : & + Inst%PLN_FRC(SFC_TYP_IDX,SGS_IDX) ! [frc]
3216 0 : & * RLM_CRR ! [m]
3217 :
3218 : ENDDO
3219 : ENDIF
3220 : ENDDO
3221 :
3222 : ! Return w/ success
3223 0 : RC = HCO_SUCCESS
3224 :
3225 : ! Return to calling program
3226 : END SUBROUTINE RGH_MMN_GET
3227 :
3228 : !------------------------------------------------------------------------------
3229 :
3230 0 : SUBROUTINE SNW_FRC_GET( HcoState, SNW_HGT_LQD, SNW_FRC )
3231 : !
3232 : !******************************************************************************
3233 : ! Subroutine SNW_FRC_GET converts equivalent liquid water snow depth to
3234 : ! fractional snow cover. Uses the snow thickness -> fraction algorithm of
3235 : ! Bon96. (tdf bmy, 3/30/04)
3236 : !
3237 : ! Arguments as Input:
3238 : ! ===========================================================================
3239 : ! (1 ) snw_hgt_lqd (REAL*8) : Equivalent liquid water snow depth [m]
3240 : !
3241 : ! Arguments as Output:
3242 : ! ===========================================================================
3243 : ! (2 ) snw_frc (REAL*8 ) : Fraction of surface covered by snow
3244 : !
3245 : ! NOTES:
3246 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
3247 : ! with "D" exponents. (bmy, 3/30/04)
3248 : !******************************************************************************
3249 : !
3250 :
3251 : !----------------
3252 : ! Arguments
3253 : !----------------
3254 : TYPE(HCO_State), POINTER :: HcoState
3255 : REAL*8, INTENT(IN) :: SNW_HGT_LQD(HcoState%NX)
3256 : REAL*8, INTENT(OUT) :: SNW_FRC(HcoState%NX)
3257 :
3258 : !----------------
3259 : ! Parameters
3260 : !----------------
3261 :
3262 : ! Note disparity in bulk snow density between CCM and LSM
3263 : ! WiW80 p. 2724, 2725 has some discussion of bulk snow density
3264 : !
3265 : ! Bulk density of snow [kg m-3]
3266 : REAL*8, PARAMETER :: DNS_H2O_SNW_GND_LSM = 250.0D0
3267 :
3268 : ! Standard bulk density of snow on ground [kg m-3]
3269 : REAL*8, PARAMETER :: DNS_H2O_SNW_GND_STD = 100.0D0
3270 :
3271 : ! Geometric snow thickness for 100% coverage ! [m]
3272 : REAL*8, PARAMETER :: SNW_HGT_THR = 0.05D0
3273 :
3274 : ! Liquid water density! [kg/m3]
3275 : REAL*8, PARAMETER :: DNS_H2O_LQD_STD = 1000.0D0
3276 :
3277 : !-----------------
3278 : ! Local variables
3279 : !-----------------
3280 :
3281 : ! [idx] Counting index for lon
3282 : INTEGER :: LON_IDX
3283 :
3284 : ! [m] Geometric bulk thickness of snow
3285 0 : REAL*8 :: SNW_HGT(HcoState%NX)
3286 :
3287 : ! Conversion factor from liquid water depth
3288 : ! to geometric snow thickness [fraction]
3289 : REAL*8 :: HGT_LQD_SNW_CNV
3290 :
3291 : !=================================================================
3292 : ! SNW_FRC_GET begins here!
3293 : !=================================================================
3294 :
3295 : ! Conversion factor from liquid water depth to
3296 : ! geometric snow thickness [fraction]
3297 : HGT_LQD_SNW_CNV = DNS_H2O_LQD_STD
3298 0 : & / DNS_H2O_SNW_GND_STD
3299 :
3300 : ! Fractional snow cover
3301 0 : DO LON_IDX = 1, HcoState%NX
3302 :
3303 : ! Snow height [m]
3304 0 : SNW_HGT(LON_IDX) = SNW_HGT_LQD(LON_IDX)
3305 0 : & * HGT_LQD_SNW_CNV
3306 :
3307 : ! Snow fraction
3308 : ! NB: CCM and LSM seem to disagree on this
3309 0 : SNW_FRC(LON_IDX) = MIN(SNW_HGT(LON_IDX)/SNW_HGT_THR, 1.0D0)
3310 : ENDDO
3311 :
3312 : ! Return to calling program
3313 0 : END SUBROUTINE SNW_FRC_GET
3314 :
3315 : !------------------------------------------------------------------------------
3316 :
3317 : SUBROUTINE WND_RFR_GET( HcoState, FLG_ORO, HGT_MDP, HGT_RFR,
3318 : & HGT_ZPD, MNO_LNG, WND_FRC, WND_MDP,
3319 : & WND_MIN, WND_RFR )
3320 : !
3321 : !******************************************************************************
3322 : ! Subroutine WND_RFR_GET interpolates wind speed at given height to wind
3323 : ! speed at reference height. (tdf, bmy, 3/30/04)
3324 : !
3325 : ! Arguments as Input:
3326 : ! ===========================================================================
3327 : ! (1 ) FLG_ORO (LOGICAL) : Orography flag (mobilization flag) [flag]
3328 : ! (2 ) HGT_MDP (REAL*8 ) : Midpoint height above surface [m ]
3329 : ! (3 ) HGT_RFR (REAL*8 ) : Reference height [m ]
3330 : ! (4 ) HGT_ZPD (REAL*8 ) : Zero plane displacement [m ]
3331 : ! (5 ) MNO_LNG (REAL*8 ) : Monin-Obukhov length [m ]
3332 : ! (6 ) WND_FRC (REAL*8 ) : Surface friction velocity [m/s ]
3333 : ! (7 ) WND_MDP (REAL*8 ) : Surface layer mean wind speed [m/s ]
3334 : ! (8 ) WND_MIN (REAL*8 ) : Minimum windspeed [m/s ]
3335 : !
3336 : ! Arguments as Output:
3337 : ! ===========================================================================
3338 : ! (9 ) WND_RFR (REAL*8 ) : Wind speed at reference height [m/s ]
3339 : !
3340 : ! NOTES:
3341 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
3342 : ! with "D" exponents. (bmy, 3/30/04)
3343 : !******************************************************************************
3344 : !
3345 :
3346 : !------------------
3347 : ! Arguments
3348 : !------------------
3349 : TYPE(HCO_State), POINTER :: HcoState
3350 : LOGICAL, INTENT(IN) :: FLG_ORO(HcoState%NX)
3351 : REAL*8, INTENT(IN) :: HGT_MDP(HcoState%NX)
3352 : REAL*8, INTENT(IN) :: HGT_RFR
3353 : REAL*8, INTENT(IN) :: HGT_ZPD(HcoState%NX)
3354 : REAL*8, INTENT(IN) :: MNO_LNG(HcoState%NX)
3355 : REAL*8, INTENT(IN) :: WND_FRC(HcoState%NX)
3356 : REAL*8, INTENT(IN) :: WND_MDP(HcoState%NX)
3357 : REAL*8, INTENT(IN) :: WND_MIN
3358 : REAL*8, INTENT(OUT) :: WND_RFR(HcoState%NX)
3359 :
3360 : !------------------
3361 : ! Parameters
3362 : !------------------
3363 :
3364 : ! Named index for lower (target) hght
3365 : INTEGER, PARAMETER :: RFR_HGT_IDX=1
3366 :
3367 : ! Named index for upper (known) hght
3368 : INTEGER, PARAMETER :: GCM_HGT_IDX=2
3369 :
3370 : !------------------
3371 : ! Local variables
3372 : !------------------
3373 :
3374 : ! [idx] Counting index
3375 : INTEGER :: IDX_IDX
3376 :
3377 : ! [idx] Counting index for lon
3378 : INTEGER :: LON_IDX
3379 :
3380 : ! Stability computation loop index
3381 : INTEGER :: LVL_IDX
3382 :
3383 : ! Valid indices
3384 : INTEGER :: VLD_IDX(HcoState%NX)
3385 :
3386 : ! [nbr] Number of valid indices
3387 : INTEGER :: VLD_NBR
3388 :
3389 : ! [frc] Monin-Obukhov stability correction momentum
3390 : REAL*8 :: MNO_STB_CRC_MMN(HcoState%NX,2)
3391 :
3392 : ! [frc] Monin-Obukhov stability parameter
3393 : REAL*8 :: MNO_STB_PRM(HcoState%NX,2)
3394 :
3395 : ! [frc] Reciprocal of similarity function
3396 : ! for momentum, unstable atmosphere
3397 : REAL*8 :: SML_FNC_MMN_UNS_RCP
3398 :
3399 : ! Term in stability correction computation
3400 : REAL*8 :: TMP2
3401 :
3402 : ! Term in stability correction computation
3403 : REAL*8 :: TMP3
3404 :
3405 : ! Term in stability correction computation
3406 : REAL*8 :: TMP4
3407 :
3408 : ! [frc] Wind correction factor
3409 : REAL*8 :: WND_CRC_FCT(HcoState%NX)
3410 :
3411 : ! [m-1] Reciprocal of reference height
3412 : REAL*8 :: HGT_RFR_RCP
3413 :
3414 : !=================================================================
3415 : ! WND_RFR_GET begins here!
3416 : !=================================================================
3417 :
3418 : HGT_RFR_RCP = 1.0D0 / HGT_RFR ! [m-1]
3419 : WND_RFR = WND_MIN ! [m s-1]
3420 :
3421 : ! Compute horizontal wind speed at reference height
3422 : DO LON_IDX = 1, HcoState%NX
3423 : IF (FLG_ORO(LON_IDX) .AND. HGT_ZPD(LON_IDX) < HGT_RFR) THEN
3424 :
3425 : ! Code uses notation of Bon96 p. 50, where lvl_idx=1
3426 : ! is 10 m ref. hgt, lvl_idx=2 is atm. hgt
3427 : MNO_STB_PRM(LON_IDX,RFR_HGT_IDX) =
3428 : & MIN((HGT_RFR-HGT_ZPD(LON_IDX))
3429 : & /MNO_LNG(LON_IDX),1.0D0) ! [frc]
3430 :
3431 : MNO_STB_PRM(LON_IDX,GCM_HGT_IDX) =
3432 : & MIN((HGT_MDP(LON_IDX)-HGT_ZPD(LON_IDX))
3433 : & /MNO_LNG(LON_IDX),1.0D0) ! [frc]
3434 :
3435 : DO LVL_IDX = 1, 2
3436 : IF (MNO_STB_PRM(LON_IDX,LVL_IDX) < 0.0D0) THEN
3437 : SML_FNC_MMN_UNS_RCP = (1.0D0 - 16.0D0
3438 : & * MNO_STB_PRM(LON_IDX,LVL_IDX))**0.25D0
3439 : TMP2 = LOG((1.0D0 + SML_FNC_MMN_UNS_RCP
3440 : & * SML_FNC_MMN_UNS_RCP)/2.0D0)
3441 : TMP3 = LOG((1.0D0 + SML_FNC_MMN_UNS_RCP)/2.0D0)
3442 : MNO_STB_CRC_MMN(LON_IDX,LVL_IDX) =
3443 : & 2.0D0 * TMP3 + TMP2 - 2.0D0
3444 : & * ATAN(SML_FNC_MMN_UNS_RCP) + 1.5707963
3445 : ELSE ! not stable
3446 : MNO_STB_CRC_MMN(LON_IDX,LVL_IDX) = -5.0D0
3447 : & * MNO_STB_PRM(LON_IDX,LVL_IDX)
3448 : ENDIF ! stable
3449 : ENDDO ! end loop over lvl_idx
3450 :
3451 : TMP4 = LOG( (HGT_MDP(LON_IDX)-HGT_ZPD(LON_IDX))
3452 : & / (HGT_RFR-HGT_ZPD(LON_IDX)) )
3453 :
3454 : ! Correct neutral stability assumption
3455 : WND_CRC_FCT(LON_IDX) = TMP4
3456 : & - MNO_STB_CRC_MMN(LON_IDX,GCM_HGT_IDX)
3457 : & + MNO_STB_CRC_MMN(LON_IDX,RFR_HGT_IDX) ! [frc]
3458 : WND_RFR(LON_IDX) = WND_MDP(LON_IDX)-WND_FRC(LON_IDX)
3459 : & * CST_VON_KRM_RCP * WND_CRC_FCT(LON_IDX) ! [m s-1]
3460 : WND_RFR(LON_IDX) = MAX(WND_RFR(LON_IDX),WND_MIN) ! [m s-1]
3461 : ENDIF
3462 : ENDDO
3463 :
3464 : ! Return to calling program
3465 : END SUBROUTINE WND_RFR_GET
3466 :
3467 : !------------------------------------------------------------------------------
3468 :
3469 0 : SUBROUTINE WND_FRC_THR_SLT_GET( HcoState, FLG_MBL,
3470 0 : & DNS_MDP, WND_FRC_THR_SLT, RC )
3471 : !
3472 : !******************************************************************************
3473 : ! Subroutine WND_FRC_THR_SLT_GET ccmputes the dry threshold friction velocity
3474 : ! for saltation -- See Zender et al. expression (1) (tdf, bmy, 3/30/04)
3475 : !
3476 : ! Arguments as Input:
3477 : ! ===========================================================================
3478 : ! (1 ) FLG_MBL (LOGICAL) : mobilisation flag
3479 : ! (2 ) DNS_MDP (REAL*8 ) : Midlayer density [kg/m3]
3480 : !
3481 : ! Arguments as Output:
3482 : ! ===========================================================================
3483 : ! (3 ) WND_FRC_THR_SLT (REAL*8 ) : Threshold friction velocity
3484 : ! for saltation [m/s]
3485 : !
3486 : ! NOTES:
3487 : ! (1 ) Updated comments, cosmetic changes. Also now force double-precision
3488 : ! with "D" exponents. (bmy, 3/30/04)
3489 : !******************************************************************************
3490 : !
3491 :
3492 : !----------------
3493 : ! Arguments
3494 : !----------------
3495 : TYPE(HCO_State), POINTER :: HcoState
3496 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
3497 : REAL*8, INTENT(IN) :: DNS_MDP(HcoState%NX)
3498 : REAL*8, INTENT(OUT) :: WND_FRC_THR_SLT(HcoState%NX)
3499 : INTEGER, INTENT(INOUT) :: RC
3500 :
3501 : !-----------------
3502 : ! Parameters
3503 : !-----------------
3504 :
3505 : ! [m] Optimal diameter for saltation,
3506 : ! IvW82 p. 117 Fgr. 8, Pye87 p. 31, MBA97 p. 4388, SRL96 (2)
3507 : REAL*8, PARAMETER :: DMT_SLT_OPT = 75.0d-6
3508 :
3509 : ! [kg m-3] Density of optimal saltation particles,
3510 : ! MBA97 p. 4388 friction velocity for saltation
3511 : REAL*8, PARAMETER :: DNS_SLT = 2650.0d0
3512 :
3513 : !-----------------
3514 : ! Local variables
3515 : !-----------------
3516 :
3517 : ! [idx] Longitude Counting Index
3518 : INTEGER :: LON_IDX
3519 :
3520 : ! Threshold friction Reynolds number
3521 : ! approximation for optimal size [frc]
3522 : REAL*8 :: RYN_NBR
3523 :
3524 : ! Density ratio factor for saltation calculation
3525 : REAL*8 :: DNS_FCT
3526 :
3527 : ! Interparticle cohesive forces factor for saltation calculation
3528 : REAL*8 :: ALPHA, BETA, GAMMA, TMP1
3529 :
3530 :
3531 : !=================================================================
3532 : ! WND_FRC_THR_SLT_GET begins here!
3533 : !=================================================================
3534 :
3535 : ! Initialize some variables
3536 : ! MaB95 pzn. for Re*t(D_opt) circumvents iterative solution
3537 : ! [frc] "B" MaB95 p. 16417 (5)
3538 :
3539 : ! [m/s] Threshold velocity
3540 0 : WND_FRC_THR_SLT(:) = 0.0D0
3541 :
3542 : ! Threshold friction Reynolds number approximation for optimal size
3543 : RYN_NBR = 0.38D0 + 1331.0D0
3544 0 : & * (100.0D0*DMT_SLT_OPT)**1.56D0
3545 :
3546 : ! tdf NB conversion of Dp to [cm]
3547 : ! Given Re*t(D_opt), compute time independent factors contributing
3548 : ! to u*t. IvW82 p. 115 (6) MaB95 p. 16417 (4) Interparticle cohesive
3549 : ! forces. see Zender et al., Equ. (1).
3550 :
3551 : ! tdf introduced beta [fraction]
3552 0 : BETA = 1.0D0+6.0D-07 / (DNS_SLT*GRV_SFC*(DMT_SLT_OPT**2.5D0))
3553 :
3554 : ! IvW82 p. 115 (6) MaB95 p. 16417 (4)
3555 0 : DNS_FCT = DNS_SLT * GRV_SFC * DMT_SLT_OPT
3556 :
3557 : ! Error check
3558 : IF ( RYN_NBR < 0.03D0 ) THEN
3559 : CALL HCO_ERROR ( 'RYN_NBR < 0.03', RC,
3560 : & THISLOC='WND_FRC_THR_SLT_GET' )
3561 : RETURN
3562 :
3563 : ELSE IF ( RYN_NBR < 10.0D0 ) THEN
3564 :
3565 : ! IvW82 p. 114 (3), MaB95 p. 16417 (6)
3566 : ! tdf introduced gamma [fraction]
3567 0 : GAMMA = -1.0D0 + 1.928D0 * (RYN_NBR**0.0922D0)
3568 : TMP1 = 0.129D0*0.129D0 * BETA / GAMMA
3569 :
3570 : ELSE
3571 :
3572 : ! ryn_nbr > 10.0D0
3573 : ! IvW82 p. 114 (3), MaB95 p. 16417 (7)
3574 : ! tdf introduced gamma [fraction]
3575 : GAMMA = 1.0D0-0.0858D0 * EXP(-0.0617D0*(RYN_NBR-10.0D0))
3576 : TMP1 = 0.12D0*0.12D0 * BETA * GAMMA * GAMMA
3577 :
3578 : ENDIF
3579 :
3580 0 : DO LON_IDX = 1, HcoState%NX
3581 :
3582 : ! Threshold friction velocity for saltation dry ground
3583 : ! tdf introduced alpha
3584 0 : ALPHA = DNS_FCT / DNS_MDP(LON_IDX)
3585 :
3586 : ! Added mobilisation constraint
3587 0 : IF ( FLG_MBL(LON_IDX) ) THEN
3588 0 : WND_FRC_THR_SLT(LON_IDX) = SQRT(TMP1) * SQRT(ALPHA) ! [m s-1]
3589 : ENDIF
3590 : ENDDO
3591 :
3592 : ! Return w/ success
3593 0 : RC = HCO_SUCCESS
3594 :
3595 : END SUBROUTINE WND_FRC_THR_SLT_GET
3596 :
3597 : !------------------------------------------------------------------------------
3598 :
3599 : SUBROUTINE WND_RFR_THR_SLT_GET( HcoState, WND_FRC,
3600 : & WND_FRC_THR_SLT, WND_MDP, WND_RFR,
3601 : & WND_RFR_THR_SLT )
3602 : !
3603 : !******************************************************************************
3604 : ! Subroutine WND_RFR_THR_SLT_GET computes the threshold horizontal wind
3605 : ! speed at reference height for saltation. (tdf, bmy, 3/30/04)
3606 : !
3607 : ! Arguments as Input:
3608 : ! ============================================================================
3609 : ! (1 ) wnd_frc (REAL*8) : Surface friction velocity [m/s]
3610 : ! (2 ) wnd_frc_thr_slt (REAL*8) : Threshold friction vel. for saltation [m/s]
3611 : ! (3 ) wnd_mdp (REAL*8) : Surface layer mean wind speed [m/s]
3612 : ! (4 ) wnd_rfr (REAL*8) : Wind speed at reference height [m/s]
3613 : !
3614 : ! Arguments as Output:
3615 : ! ============================================================================
3616 : ! (5 ) wnd_rfr_thr_slt (REAL*8) : Threshold 10m wind speed for saltation [m/s]
3617 : !
3618 : ! NOTES:
3619 : ! (1 ) Updated comments, cosmetic changes.
3620 : !******************************************************************************
3621 : !
3622 : ! Arguments
3623 : TYPE(HCO_State), POINTER :: HcoState
3624 : REAL*8, INTENT(IN) :: WND_FRC(HcoState%NX)
3625 : REAL*8, INTENT(IN) :: WND_FRC_THR_SLT(HcoState%NX)
3626 : REAL*8, INTENT(IN) :: WND_MDP(HcoState%NX)
3627 : REAL*8, INTENT(IN) :: WND_RFR(HcoState%NX)
3628 : REAL*8, INTENT(OUT) :: WND_RFR_THR_SLT(HcoState%NX)
3629 :
3630 : ! Local variables
3631 : INTEGER :: I
3632 :
3633 : !=================================================================
3634 : ! WND_RFR_THR_SLT_GET begins here
3635 : !=================================================================
3636 : DO I = 1, HcoState%NX
3637 :
3638 : ! A more complicated procedure would recompute mno_lng for
3639 : ! wnd_frc_thr, and then integrate vertically from rgh_mmn+hgt_zpd
3640 : ! to hgt_rfr.
3641 : !
3642 : ! wnd_crc_fct is (1/k)*[ln(z-D)/z0 - psi(zeta2) + psi(zeta1)]
3643 : WND_RFR_THR_SLT(I) = WND_FRC_THR_SLT(I)
3644 : & * WND_RFR(I) / WND_FRC(I)
3645 :
3646 : ENDDO
3647 :
3648 : ! Return to calling program
3649 : END SUBROUTINE WND_RFR_THR_SLT_GET
3650 :
3651 : !------------------------------------------------------------------------------
3652 :
3653 0 : SUBROUTINE VWC2GWC( HcoState, FLG_MBL, GWC_SFC, VWC_SAT, VWC_SFC )
3654 : !
3655 : !******************************************************************************
3656 : ! Subroutine VWC2GWC converts volumetric water content to gravimetric water
3657 : ! content -- assigned only for mobilisation candidates. (tdf, bmy, 3/30/04)
3658 : !
3659 : ! Arguments as Input:
3660 : ! ===========================================================================
3661 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [flag]
3662 : ! (3 ) VWC_SAT (REAL*8 ) : Saturated VWC (sand-dependent) [m3/m3]
3663 : ! (4 ) VWC_SFC (REAL*8 ) : Volumetric water content! [m3/m3
3664 : !
3665 : ! Arguments as Output:
3666 : ! ===========================================================================
3667 : ! (2 ) gwc_sfc (REAL*8 ) : Gravimetric water content [kg/kg]
3668 : !
3669 : ! NOTES:
3670 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
3671 : ! with "D" exponents. (tdf, bmy, 3/30/04)
3672 : !******************************************************************************
3673 : !
3674 :
3675 : !----------------
3676 : ! Arguments
3677 : !----------------
3678 : TYPE(HCO_State), POINTER :: HcoState
3679 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
3680 : REAL*8, INTENT(IN) :: VWC_SAT(HcoState%NX)
3681 : REAL*8, INTENT(IN) :: VWC_SFC(HcoState%NX)
3682 : REAL*8, INTENT(OUT) :: GWC_SFC(HcoState%NX)
3683 :
3684 : !----------------
3685 : ! Parameters
3686 : !----------------
3687 :
3688 : ! Dry density of soil ! particles (excluding pores) [kg/m3]
3689 : REAL*8, PARAMETER :: DNS_PRT_SFC = 2650.0d0
3690 :
3691 : ! liq. H2O density [kg/m3]
3692 : REAL*8, PARAMETER :: DNS_H2O_LQD_STD = 1000.0d0
3693 :
3694 : !-----------------
3695 : ! Local variables
3696 : !-----------------
3697 :
3698 : ! Longitude index
3699 : INTEGER :: LON_IDX
3700 :
3701 : ! [kg m-3] Bulk density of dry surface soil
3702 0 : REAL*8 :: DNS_BLK_DRY(HcoState%NX)
3703 :
3704 : !=================================================================
3705 : ! VWC2GWC begins here!
3706 : !=================================================================
3707 0 : GWC_SFC(:) = 0.0D0
3708 0 : DNS_BLK_DRY(:) = 0.0D0
3709 :
3710 : ! Loop over longitudes
3711 0 : DO LON_IDX = 1, HcoState%NX
3712 :
3713 : ! If this is a mobilization candidate then...
3714 0 : IF ( FLG_MBL(LON_IDX) ) THEN
3715 :
3716 : ! Assume volume of air pores when dry equals saturated VWC
3717 : ! This implies air pores are completely filled by water in
3718 : ! saturated soil
3719 :
3720 : ! Bulk density of dry surface soil [kg m-3]
3721 : DNS_BLK_DRY(LON_IDX) = DNS_PRT_SFC
3722 0 : & * ( 1.0d0 - VWC_SAT(LON_IDX) )
3723 :
3724 : ! Gravimetric water content [ kg kg-1]
3725 : GWC_SFC(LON_IDX) = VWC_SFC(LON_IDX)
3726 : & * DNS_H2O_LQD_STD
3727 0 : & / DNS_BLK_DRY(LON_IDX)
3728 :
3729 : ENDIF
3730 : ENDDO
3731 :
3732 : ! Return to calling program
3733 0 : END SUBROUTINE VWC2GWC
3734 :
3735 : !------------------------------------------------------------------------------
3736 :
3737 0 : SUBROUTINE FRC_THR_NCR_WTR_GET( HcoState, FLG_MBL,
3738 0 : & FRC_THR_NCR_WTR, MSS_FRC_CLY_SLC, GWC_SFC )
3739 : !
3740 : !******************************************************************************
3741 : ! Subroutine FRC_THR_NCR_WTR_GET computes the factor by which soil moisture
3742 : ! increases threshold friction velocity. This parameterization is based on
3743 : ! FMB99. Zender et al., exp. (5). (tdf, bmy, 4/5/04)
3744 : !
3745 : ! Arguments as Input:
3746 : ! ===========================================================================
3747 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [flags ]
3748 : ! (3 ) MSS_FRC_CLY (REAL*8 ) : Mass fraction of clay [fraction]
3749 : ! (4 ) GWC_SFC (REAL*8 ) : Gravimetric water content [kg/kg ]
3750 : !
3751 : ! Arguments as Output:
3752 : ! ===========================================================================
3753 : ! (2 ) FRC_THR_NCR_WTR (REAL*8 ) : Factor by which moisture increases
3754 : ! threshold friction velocity [fraction]
3755 : !
3756 : ! NOTES:
3757 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
3758 : ! with "D" exponents. (tdf, bmy, 4/5/04)
3759 : !******************************************************************************
3760 : !
3761 :
3762 : ! Arguments
3763 : TYPE(HCO_State), POINTER :: HcoState
3764 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
3765 : REAL*8, INTENT(IN) :: MSS_FRC_CLY_SLC(HcoState%NX)
3766 : REAL*8, INTENT(IN) :: GWC_SFC(HcoState%NX)
3767 : REAL*8, INTENT(OUT) :: FRC_THR_NCR_WTR(HcoState%NX)
3768 :
3769 : ! local variables
3770 : INTEGER :: LON_IDX ! [idx] Counting index
3771 0 : REAL*8 :: GWC_THR(HcoState%NX) ! [kg/kg] Threshold GWC
3772 :
3773 : !=================================================================
3774 : ! FRC_THR_NCR_WTR_GET begins here!
3775 : !=================================================================
3776 :
3777 : ! Initialize
3778 0 : frc_thr_ncr_wtr(:) = 1.0D0
3779 0 : gwc_thr(:) = 0.0D0
3780 :
3781 : ! Loop over longitudes
3782 0 : DO LON_IDX = 1, HcoState%NX
3783 :
3784 : ! If this is a candidate for mobilization...
3785 0 : IF ( FLG_MBL(LON_IDX) ) THEN
3786 :
3787 : !===========================================================
3788 : ! Adjust threshold velocity for inhibition by moisture
3789 : ! frc_thr_ncr_wtr(lon_idx)=exp(22.7D0*vwc_sfc(lon_idx))
3790 : ! [frc] SRL96
3791 : !
3792 : ! Compute threshold soil moisture based on clay content
3793 : ! GWC_THR=MSS_FRC_CLY*(0.17D0+0.14D0*MSS_FRC_CLY) [m3/m3]
3794 : ! FMB99 p. 155 (14)
3795 : !
3796 : ! 19991105 remove factor of mss_frc_cly from gwc_thr to
3797 : ! improve large scale behavior.
3798 : !===========================================================
3799 :
3800 : ! [m3 m-3]
3801 0 : GWC_THR(LON_IDX) = 0.17D0 + 0.14D0* MSS_FRC_CLY_SLC(LON_IDX)
3802 :
3803 0 : IF ( GWC_SFC(LON_IDX) > GWC_THR(LON_IDX) )
3804 : & FRC_THR_NCR_WTR(LON_IDX) = SQRT(1.0D0+1.21D0
3805 : & * (100.0D0 * (GWC_SFC(LON_IDX)-GWC_THR(LON_IDX)))
3806 0 : & ** 0.68D0) ! [frc] FMB99 p. 155 (15)
3807 : ENDIF
3808 : ENDDO
3809 :
3810 : ! Return to calling program
3811 0 : END SUBROUTINE FRC_THR_NCR_WTR_GET
3812 :
3813 : !------------------------------------------------------------------------------
3814 :
3815 : SUBROUTINE FRC_THR_NCR_DRG_GET( HcoState, FRC_THR_NCR_DRG,
3816 : & FLG_MBL, Z0M, ZS0M, RC )
3817 : !
3818 : !******************************************************************************
3819 : ! Subroutine FRC_THR_NCR_DRG_GET computes factor by which surface roughness
3820 : ! increases threshold friction velocity. Zender et al., expression (3)
3821 : ! This parameterization is based on MaB95 and GMB98. (tdf, bmy, 4/5/04)
3822 : !
3823 : ! Arguments as Input:
3824 : ! ===========================================================================
3825 : ! (2 ) FLG_MBL (LOGICAL) : Mobilization candidate flag
3826 : ! (3 ) Z0M (REAL*8 ) : Roughness length momentum
3827 : ! : for erodible surfaces [m]
3828 : ! (4 ) ZS0M (REAL*8 ) : Smooth roughness length [m]
3829 : !
3830 : ! Arguments as Output:
3831 : ! ===========================================================================
3832 : ! (1 ) FRC_THR_NCR_DRG (REAL*8 ) : Factor by which surface roughness
3833 : ! increases threshold fric. velocity [frac]
3834 : !
3835 : ! NOTES:
3836 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
3837 : ! with "D" exponents. (tdf, bmy, 4/5/04)
3838 : !******************************************************************************
3839 : !
3840 :
3841 : !-----------------
3842 : ! Arguments
3843 : !-----------------
3844 : TYPE(HCO_State), POINTER :: HcoState
3845 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
3846 : REAL*8, INTENT(IN) :: Z0M
3847 : REAL*8, INTENT(IN) :: ZS0M
3848 : REAL*8, INTENT(OUT) :: FRC_THR_NCR_DRG(HcoState%NX)
3849 : INTEGER, INTENT(INOUT) :: RC
3850 :
3851 : !-----------------
3852 : ! Local variables
3853 : !-----------------
3854 :
3855 : ! [idx] Counting index
3856 : integer lon_idx
3857 :
3858 : ! [frc] Efficient fraction of wind friction
3859 : real*8 Feff
3860 :
3861 : ! [frc] Reciprocal of Feff
3862 : real*8 Feff_rcp
3863 :
3864 : ! for error handling
3865 : CHARACTER(LEN=255) :: MSG
3866 :
3867 : !=================================================================
3868 : ! FRC_THR_NCR_DRG_GET begins here!
3869 : !=================================================================
3870 :
3871 : FRC_THR_NCR_DRG(:) = 1.0D0
3872 :
3873 : ! Adjust threshold velocity for inhibition by roughness elements
3874 : ! Zender et al. Equ. (3), fd.
3875 :
3876 : ! [frc] MaB95 p. 16420, GMB98 p. 6207
3877 : FEFF = 1.0D0 - LOG( Z0M /ZS0M )
3878 : & / LOG( 0.35D0*( (0.1D0/ZS0M)**0.8D0) )
3879 :
3880 : ! Error check
3881 : if ( FEFF <= 0.0D0 .OR. FEFF > 1.0D0 ) THEN
3882 : MSG = 'Feff out of range!'
3883 : CALL HCO_ERROR(MSG, RC,
3884 : & THISLOC='FRC_THR_NC_DRG_GET' )
3885 : RETURN
3886 : ENDIF
3887 :
3888 : ! Reciprocal of FEFF [fraction]
3889 : FEFF_RCP = 1.0D0 / FEFF
3890 :
3891 : ! Loop over longitudes
3892 : DO LON_IDX = 1, HcoState%NX
3893 :
3894 : ! If this is a mobilization candidate...
3895 : IF ( FLG_MBL(LON_IDX) ) THEN
3896 :
3897 : ! Save into FRC_THR_NCR_DRG
3898 : FRC_THR_NCR_DRG(LON_IDX) = FEFF_RCP
3899 :
3900 : ! fxm: 19991012
3901 : ! Set frc_thr_ncr_drg=1.0, equivalent to assuming mobilization
3902 : ! takes place at smooth roughness length
3903 : FRC_THR_NCR_DRG(LON_IDX) = 1.0D0
3904 :
3905 : ENDIF
3906 : ENDDO
3907 :
3908 : ! Return w/ success
3909 : RC = HCO_SUCCESS
3910 :
3911 : END SUBROUTINE FRC_THR_NCR_DRG_GET
3912 :
3913 : !------------------------------------------------------------------------------
3914 :
3915 0 : SUBROUTINE WND_FRC_SLT_GET( HcoState, FLG_MBL, WND_FRC,
3916 0 : & WND_FRC_SLT, WND_RFR, WND_RFR_THR_SLT)
3917 : !
3918 : !******************************************************************************
3919 : ! Subroutine WND_FRC_SLT_GET computes the saltating friction velocity.
3920 : ! Saltation increases friction speed by roughening surface, AKA "Owen's
3921 : ! effect". This acts as a positive feedback to the friction speed. GMB98
3922 : ! parameterized this feedback in terms of 10 m windspeeds, Zender et al.
3923 : ! equ. (4). (tdf, bmy, 4/5/04, 1/25/07)
3924 : !
3925 : ! Arguments as Input:
3926 : ! ===========================================================================
3927 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag
3928 : ! (2 ) WND_FRC (REAL*8 ) : Surface friction velocity [m/s]
3929 : ! (4 ) WND_RFR (REAL*8 ) : Wind speed at reference height [m/s]
3930 : ! (5 ) WND_RFR_THR_SLT (REAL*8 ) : Thresh. 10m wind speed for saltation [m/s]
3931 : !
3932 : ! Arguments as Output:
3933 : ! ===========================================================================
3934 : ! (3 ) WND_FRC_SLT (REAL*8 ) : Saltating friction velocity [m/s]
3935 : !
3936 : ! NOTES:
3937 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
3938 : ! with "D" exponents. (tdf, bmy, 4/5/04)
3939 : ! (2 ) Now eliminate Owen effect (tdf, bmy, 1/25/07)
3940 : !******************************************************************************
3941 : !
3942 :
3943 : !-------------------
3944 : ! Arguments
3945 : !-------------------
3946 : TYPE(HCO_State), POINTER :: HcoState
3947 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
3948 : REAL*8, INTENT(IN) :: WND_FRC(HcoState%NX)
3949 : REAL*8, INTENT(IN) :: WND_RFR(HcoState%NX)
3950 : REAL*8, INTENT(IN) :: WND_RFR_THR_SLT(HcoState%NX)
3951 : REAL*8, INTENT(OUT) :: WND_FRC_SLT(HcoState%NX)
3952 :
3953 : !-------------------
3954 : ! Local variables
3955 : !-------------------
3956 :
3957 : ! [idx] Counting index
3958 : INTEGER :: LON_IDX
3959 :
3960 : !---------------------------------------------------------------------
3961 : ! Prior to 1/25/07:
3962 : ! Eliminate Owen effect, so comment out this code (tdf, bmy, 1/25/07)
3963 : !
3964 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
3965 : !
3966 : !! [m/s] Reference windspeed excess over threshold
3967 : !REAL*8 :: WND_RFR_DLT
3968 : !
3969 : !! [m/s] Friction velocity increase from saltation
3970 : !REAL*8 :: WND_FRC_SLT_DLT
3971 : !---------------------------------------------------------------------
3972 :
3973 : !=================================================================
3974 : ! WND_FRC_SLT_GET begins here!
3975 : !=================================================================
3976 :
3977 : ! [m/s] Saltating friction velocity
3978 0 : WND_FRC_SLT(:) = WND_FRC(:)
3979 :
3980 : !------------------------------------------------------------------------------
3981 : ! Prior to 1/25/07:
3982 : ! Eliminate the Owen effect. Note that the more computationally
3983 : ! efficient way to do this is to just comment out the entire IF block.
3984 : ! (tdf, bmy, 1/25/07)
3985 : !
3986 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
3987 : !
3988 : ! ! Loop over longitudes
3989 : ! DO LON_IDX = 1, HcoState%NX
3990 : !
3991 : ! ! If this is a mobilization candidate, then only
3992 : ! ! only apply Owen effect only when Uref > Ureft (tdf 4/5/04)
3993 : ! IF ( FLG_MBL(LON_IDX) .AND.
3994 : ! & WND_RFR(LON_IDX) >= WND_RFR_THR_SLT(LON_IDX) ) THEN
3995 : !
3996 : ! !==================================================================
3997 : ! ! Saltation roughens the boundary layer, AKA "Owen's effect"
3998 : ! ! GMB98 p. 6206 Fig. 1 shows observed/computed u* dependence
3999 : ! ! on observed U(1 m). GMB98 p. 6209 (12) has u* in cm s-1 and
4000 : ! ! U, Ut in m s-1, personal communication, D. Gillette, 19990529
4001 : ! ! With everything in MKS, the 0.3 coefficient in GMB98 (12)
4002 : ! ! becomes 0.003. Increase in friction velocity due to saltation
4003 : ! ! varies as square of difference between reference wind speed
4004 : ! ! and reference threshold speed.
4005 : ! !==================================================================
4006 : ! WND_RFR_DLT = WND_RFR(LON_IDX) - WND_RFR_THR_SLT(LON_IDX)
4007 : !
4008 : ! ! Friction velocity increase from saltation GMB98 p. 6209 [m/s]
4009 : ! wnd_frc_slt_dlt = 0.003D0 * wnd_rfr_dlt * wnd_rfr_dlt
4010 : !
4011 : ! ! Saltation friction velocity, U*,s, Zender et al. Equ. (4).
4012 : ! WND_FRC_SLT(LON_IDX) = WND_FRC(LON_IDX)
4013 : ! & + WND_FRC_SLT_DLT ! [m s-1]
4014 : !
4015 : ! !
4016 : !ctdf Eliminate Owen effect tdf 01/13/2K5
4017 : ! wnd_frc_slt(:) = wnd_frc(:)
4018 : !
4019 : ! ENDIF
4020 : ! ENDDO
4021 : !------------------------------------------------------------------------------
4022 :
4023 : ! Return to calling program
4024 0 : END SUBROUTINE WND_FRC_SLT_GET
4025 :
4026 : !------------------------------------------------------------------------------
4027 :
4028 : SUBROUTINE FLX_MSS_CACO3_MSK( HcoState, ExtState,
4029 : & DMT_VWR,
4030 : & FLG_MBL,
4031 : & FLX_MSS_VRT_DST_CACO3,
4032 : & MSS_FRC_CACO3_SLC,
4033 : & MSS_FRC_CLY_SLC,
4034 : & MSS_FRC_SND_SLC, RC )
4035 : !
4036 : !******************************************************************************
4037 : ! Subroutine FLX_MSS_CACO3_MSK masks dust mass flux by CaCO3 mass fraction at
4038 : ! source. Theory: Uses soil CaCO3 mass fraction from Global Soil Data Task,
4039 : ! 1999 (Sch99). Uses size dependent apportionment of CaCO3 from Claquin et
4040 : ! al, 1999 (CSB99). (tdf, bmy, 4/5/04)
4041 : !
4042 : ! Arguments as Input:
4043 : ! ===========================================================================
4044 : ! (1 ) DMT_VWR (REAL*8 ) : Mass weighted diameter resolved [m]
4045 : ! (2 ) FLG_MBL (LOGICAL) : Mobilization candidate flag
4046 : ! (3 ) FLX_MSS_VRT_DST_CACO3 (REAL*8 ) : Vert. mass flux of dust [kg/m2/s ]
4047 : ! (4 ) MSS_FRC_CACO3 (REAL*8 ) : Mass fraction of CaCO3 [fraction]
4048 : ! (5 ) MSS_FRC_CLY (REAL*8 ) : Mass fraction of clay [fraction]
4049 : ! (6 ) MSS_FRC_SND (REAL*8 ) : Mass fraction of sand [fraction]
4050 : !
4051 : ! Arguments as Output:
4052 : ! ===========================================================================
4053 : ! (3 ) FLX_MSS_VRT_DST_CACO3 (REAL*8 ) : Vertical mass flux of CaCO3 [kg/m2/s]
4054 : !
4055 : ! NOTES:
4056 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4057 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4058 : !******************************************************************************
4059 : !
4060 :
4061 : !------------------
4062 : ! Arguments
4063 : !------------------
4064 : TYPE(HCO_State), POINTER :: HcoState
4065 : TYPE(Ext_State), POINTER :: ExtState
4066 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
4067 : REAL*8, INTENT(IN) :: DMT_VWR(NBINS)
4068 : REAL*8, INTENT(IN) :: MSS_FRC_CACO3_SLC(HcoState%NX)
4069 : REAL*8, INTENT(IN) :: MSS_FRC_CLY_SLC(HcoState%NX)
4070 : REAL*8, INTENT(IN) :: MSS_FRC_SND_SLC(HcoState%NX)
4071 : REAL*8, INTENT(INOUT) :: FLX_MSS_VRT_DST_CACO3(HcoState%NX,NBINS)
4072 : INTEGER, INTENT(INOUT) :: RC
4073 :
4074 : !------------------
4075 : ! Parameters
4076 : !------------------
4077 :
4078 : ! Maximum diameter of Clay soil texture CSB99 p. 22250 [m]
4079 : REAL*8, PARAMETER :: DMT_CLY_MAX = 2.0d-6
4080 :
4081 : ! Maximum diameter of Silt soil texture CSB99 p. 22250 [m]
4082 : REAL*8, PARAMETER :: DMT_SLT_MAX = 50.0d-6
4083 :
4084 : ! Density of CaCO3 http://www.ssc.on.ca/mandm/calcit.htm [kg/m3]
4085 : REAL*8, PARAMETER :: DNS_CACO3 = 2950.0d0
4086 :
4087 : !------------------
4088 : ! Local variables
4089 : !------------------
4090 :
4091 : ! [idx] Counting index
4092 : INTEGER :: M
4093 :
4094 : ! [idx] Counting index for lon
4095 : INTEGER :: LON_IDX
4096 :
4097 : ! [frc] Mass fraction of silt
4098 : REAL*8 :: MSS_FRC_SLT_SLC(HcoState%NX)
4099 :
4100 : ! [frc] Fraction of soil CaCO3 in size bin
4101 : REAL*8 :: MSS_FRC_CACO3_SZ_CRR
4102 :
4103 : ! [frc] Fraction of CaCO3 in clay
4104 : REAL*8 :: MSS_FRC_CACO3_CLY
4105 :
4106 : ! [frc] Fraction of CaCO3 in silt
4107 : REAL*8 :: MSS_FRC_CACO3_SLT
4108 :
4109 : ! [frc] Fraction of CaCO3 in sand
4110 : REAL*8 :: MSS_FRC_CACO3_SND
4111 :
4112 : ! Error handling
4113 : CHARACTER(LEN=255) :: MSG
4114 :
4115 : !=================================================================
4116 : ! FLX_MSS_CACO3_MSK
4117 : !=================================================================
4118 :
4119 : ! INITIALIZE
4120 : MSS_FRC_SLT_SLC(:) = 0.0D0
4121 :
4122 : ! Loop over dust bins
4123 : DO M = 1, NBINS
4124 :
4125 : ! Loop over longitudes
4126 : DO LON_IDX = 1, HcoState%NX
4127 :
4128 : !===========================================================
4129 : ! Simple technique is to mask dust mass by tracer mass
4130 : ! fraction. The model transports (hence conserves) CaCO3
4131 : ! rather than total dust itself. The method assumes source,
4132 : ! transport, and removal processes are linear with tracer
4133 : ! mass
4134 : !===========================================================
4135 :
4136 : ! If this is a mobilization candidate, then...
4137 : IF ( FLG_MBL(LON_IDX) ) THEN
4138 :
4139 : ! 20000320: Currently this is only process in
4140 : ! dust model requiring mss_frc_slt
4141 :
4142 : ! [frc] Mass fraction of silt
4143 : MSS_FRC_SLT_SLC(LON_IDX) =
4144 : & MAX(0.0D0, 1.0D0 -MSS_FRC_CLY_SLC(LON_IDX)
4145 : & -MSS_FRC_SND_SLC(LON_IDX))
4146 :
4147 : ! CSB99 showed that CaCO3 is not uniformly distributed
4148 : ! across sizes. There is more CaCO3 per unit mass of
4149 : ! silt than per unit mass of clay.
4150 :
4151 : ! Fraction of CaCO3 in clay CSB99 p. 22249 Figure 1b
4152 : MSS_FRC_CACO3_CLY = MAX(0.0D0,-0.045D0+0.5D0
4153 : & * MIN(0.5D0,MSS_FRC_CLY_SLC(LON_IDX)))
4154 :
4155 : ! Fraction of CaCO3 in silt CSB99 p. 22249 Figure 1a
4156 : MSS_FRC_CACO3_SLT = MAX(0.0D0,-0.175D0+1.4D0
4157 : & * MIN(0.5D0,MSS_FRC_SLT_SLC(LON_IDX)))
4158 :
4159 : ! Fraction of CaCO3 in sand CSB99 p. 22249 Figure 1a
4160 : MSS_FRC_CACO3_SND = 1.0D0 - MSS_FRC_CACO3_CLY
4161 : & - MSS_FRC_CACO3_SND
4162 :
4163 : ! Set CaCO3 fraction of total CaCO3 for each transport bin
4164 : IF ( DMT_VWR(M) < DMT_CLY_MAX ) THEN
4165 :
4166 : ! Transport bin carries Clay
4167 : ! Fraction of soil CaCO3 in size bin
4168 : MSS_FRC_CACO3_SZ_CRR = MSS_FRC_CACO3_CLY
4169 :
4170 : ELSE IF ( DMT_VWR(M) < DMT_SLT_MAX ) THEN
4171 :
4172 : ! Transport bin carries Silt
4173 : ! Fraction of soil CaCO3 in size bin
4174 : MSS_FRC_CACO3_SZ_CRR = MSS_FRC_CACO3_SLT
4175 :
4176 : ELSE
4177 :
4178 : ! Transport bin carries Sand
4179 : ! Fraction of soil CaCO3 in size bin
4180 : MSS_FRC_CACO3_SZ_CRR = MSS_FRC_CACO3_SND
4181 :
4182 : ENDIF
4183 :
4184 : ! Error checks
4185 : IF ( MSS_FRC_CACO3_SZ_CRR < 0.0D0 .OR.
4186 : & MSS_FRC_CACO3_SZ_CRR > 1.0D0 ) THEN
4187 : MSG = 'mss_frc_CaC_s < 0.0.or.mss_frc_CaC_s > 1.0!'
4188 : CALL HCO_ERROR(MSG, RC,
4189 : & THISLOC='FLX_MSS_CACO3_MSK' )
4190 : RETURN
4191 : ENDIF
4192 :
4193 : IF ( MSS_FRC_CACO3_SLC(LON_IDX) < 0.0D0 .OR.
4194 : & MSS_FRC_CACO3_SLC(LON_IDX) > 1.0D0 ) THEN
4195 : MSG = 'mss_frc_CaCO3_s < 0.0.or.mss_frc_CaCO3 > 1.0!'
4196 : CALL HCO_ERROR(MSG, RC,
4197 : & THISLOC='FLX_MSS_CACO3_MSK' )
4198 : RETURN
4199 : ENDIF
4200 :
4201 : ! Convert dust flux to CaCO3 flux
4202 : FLX_MSS_VRT_DST_CACO3(LON_IDX,M) =
4203 : & FLX_MSS_VRT_DST_CACO3(LON_IDX,M) ! [KG m-2 s-1]
4204 : & * MSS_FRC_CACO3_SLC(LON_IDX) ! [frc] Mass fraction of
4205 : ! CaCO3 (at this location)
4206 : ! 20020925 fxm: Remove size dependence of CaCO3
4207 : & * 1.0D0
4208 :
4209 : ENDIF
4210 : ENDDO
4211 : ENDDO
4212 :
4213 : ! Return w/ success
4214 : RC = HCO_SUCCESS
4215 :
4216 : END SUBROUTINE FLX_MSS_CACO3_MSK
4217 :
4218 : !------------------------------------------------------------------------------
4219 :
4220 0 : SUBROUTINE FLX_MSS_HRZ_SLT_TTL_WHI79_GET( HcoState, DNS_MDP,
4221 0 : & FLG_MBL, QS_TTL, U_S, U_ST )
4222 : !
4223 : !******************************************************************************
4224 : ! Subroutine FLX_MSS_HRZ_SLT_TTL_WHI79_GET computes vertically integrated
4225 : ! streamwise mass flux of particles. Theory: Uses method proposed by White
4226 : ! (1979). See Zender et al., expr (10). fxm: use surface air density not
4227 : ! midlayer density (tdf, bmy, 4/5/04)
4228 : !
4229 : ! Arguments as Input:
4230 : ! ============================================================================
4231 : ! (1 ) DNS_MDP (REAL*8 ) : Midlayer density [g/m3 ]
4232 : ! (2 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [flag ]
4233 : ! (4 ) U_S (REAL*8 ) : Surface friction velocity [m/s ]
4234 : ! (5 ) U_ST (REAL*8 ) : Threshold friction spd for saltation [m/s ]
4235 : !
4236 : ! Arguments as Output:
4237 : ! ============================================================================
4238 : ! (3 ) QS_TTL (REAL*8 ) : Vertically integrated streamwise mass flux [kg/m/s]
4239 : !
4240 : ! NOTES:
4241 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4242 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4243 : !******************************************************************************
4244 : !
4245 :
4246 : !------------------
4247 : ! Arguments
4248 : !------------------
4249 : TYPE(HCO_State), POINTER :: HcoState
4250 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
4251 : REAL*8, INTENT(IN) :: DNS_MDP(HcoState%NX)
4252 : REAL*8, INTENT(IN) :: U_S(HcoState%NX)
4253 : REAL*8, INTENT(IN) :: U_ST(HcoState%NX)
4254 : REAL*8, INTENT(OUT) :: QS_TTL(HcoState%NX)
4255 :
4256 : !------------------
4257 : ! Parameters
4258 : !------------------
4259 :
4260 : ! [frc] Saltation constant Whi79 p. 4648, MaB97 p. 16422
4261 : REAL*8, PARAMETER :: CST_SLT = 2.61d0
4262 :
4263 : !------------------
4264 : ! Local variables
4265 : !------------------
4266 :
4267 : ! [frc] Ratio of wind friction threshold to wind friction
4268 : real*8 :: U_S_rat
4269 :
4270 : ! [idx] Counting index for lon
4271 : integer :: lon_idx
4272 :
4273 : !=================================================================
4274 : ! FLX_MSS_HRZ_SLT_TTL_WHI79_GET begins here!
4275 : !=================================================================
4276 :
4277 : ! Initialize
4278 0 : QS_TTL(:) = 0.0D0
4279 :
4280 : ! Loop over longitudes
4281 0 : DO LON_IDX = 1, HcoState%NX
4282 :
4283 : ! If this is a mobilization candidate and the friction
4284 : ! velocity is above the threshold for saltation...
4285 0 : IF ( FLG_MBL(LON_IDX) .AND.
4286 0 : & U_S(LON_IDX) > U_ST(LON_IDX) ) THEN
4287 :
4288 : ! Ratio of wind friction threshold to wind friction
4289 0 : U_S_RAT = U_ST(LON_IDX) / U_S(LON_IDX)
4290 :
4291 : ! Whi79 p. 4648 (19), MaB97 p. 16422 (28)
4292 : QS_TTL(LON_IDX) = ! [kg m-1 s-1]
4293 : & CST_SLT * DNS_MDP(LON_IDX) * (U_S(LON_IDX)**3.0D0)
4294 : & * (1.0D0-U_S_RAT) * (1.0D0+U_S_RAT)
4295 0 : & * (1.0D0+U_S_RAT) / GRV_SFC
4296 :
4297 : ENDIF
4298 : ENDDO
4299 :
4300 : ! Return to calling program
4301 0 : END SUBROUTINE FLX_MSS_HRZ_SLT_TTL_WHI79_GET
4302 :
4303 : !------------------------------------------------------------------------------
4304 :
4305 0 : SUBROUTINE FLX_MSS_VRT_DST_TTL_MAB95_GET( HcoState,
4306 0 : & DST_SLT_FLX_RAT_TTL,
4307 0 : & FLG_MBL,
4308 0 : & FLX_MSS_HRZ_SLT_TTL,
4309 0 : & FLX_MSS_VRT_DST_TTL,
4310 0 : & MSS_FRC_CLY_SLC )
4311 : !
4312 : !******************************************************************************
4313 : ! Subroutine FLX_MSS_VRT_DST_TTL_MAB95_GET diagnoses total vertical mass flux
4314 : ! of dust from vertically integrated streamwise mass flux, Zender et al.,
4315 : ! expr. (11). (tdf, bmy, 4/5/04)
4316 : !
4317 : ! Theory: Uses clay-based method proposed by Marticorena & Bergametti (1995)
4318 : ! Their parameterization is based only on data for mss_frc_cly < 0.20
4319 : ! For clayier soils, dst_slt_flx_rat_ttl may behave dramatically differently
4320 : ! Whether this behavior changes when mss_frc_cly > 0.20 is unknown
4321 : ! Anecdotal evidence suggests vertical flux decreases for mss_frc_cly > 0.20
4322 : ! Thus we use min[mss_frc_cly,0.20] in MaB95 parameterization
4323 : !
4324 : ! Arguments as Input:
4325 : ! ============================================================================
4326 : ! (2 ) FLG_MBL (LOGICAL) : Mobilization candidate flag
4327 : ! (3 ) FLX_MSS_HRZ_SLT_TTL (REAL*8 ) : Vertically integrated streamwise
4328 : ! mass flux [kg/m/s]
4329 : ! (5 ) MSS_FRC_CLY (REAL*8 ) : Mass fraction clay [fraction]
4330 : !
4331 : ! Arguments as Output:
4332 : ! ============================================================================
4333 : ! (1 ) DST_SLT_FLX_RAT_TTL (REAL*8 ) : Ratio of vertical dust flux t
4334 : ! to streamwise mass flux [1/m]
4335 : ! (4 ) FX_MSS_VRT_DST_TTL (REAL*8 ) : Total vert. mass flux of dust [kg/m2/s]
4336 : !
4337 : ! NOTES:
4338 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4339 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4340 : !******************************************************************************
4341 : !
4342 :
4343 : !-----------------
4344 : ! Arguments
4345 : !-----------------
4346 : TYPE(HCO_State), POINTER :: HcoState
4347 : LOGICAL, INTENT(IN) :: FLG_MBL(HcoState%NX)
4348 : REAL*8, INTENT(IN) :: FLX_MSS_HRZ_SLT_TTL(HcoState%NX)
4349 : REAL*8, INTENT(IN) :: MSS_FRC_CLY_SLC(HcoState%NX)
4350 : REAL*8, INTENT(OUT) :: DST_SLT_FLX_RAT_TTL(HcoState%NX)
4351 : REAL*8, INTENT(OUT) :: FLX_MSS_VRT_DST_TTL(HcoState%NX)
4352 :
4353 : !-----------------
4354 : ! Local variables
4355 : !-----------------
4356 :
4357 : ! [idx] Counting index for lon
4358 : INTEGER :: LON_IDX
4359 :
4360 : ! [frc] Mass fraction clay limited to 0.20
4361 : REAL*8 :: MSS_FRC_CLY_VLD
4362 :
4363 : ! [frc] Natural log of 10
4364 : REAL*8 :: LN10
4365 :
4366 : !=================================================================
4367 : ! FLX_MSS_VRT_DST_TTL_MAB95_GET
4368 : !=================================================================
4369 :
4370 : ! Initialize
4371 0 : LN10 = LOG(10.0D0)
4372 0 : DST_SLT_FLX_RAT_TTL(:) = 0.0D0
4373 0 : FLX_MSS_VRT_DST_TTL(:) = 0.0D0
4374 :
4375 : ! Loop over longitudes
4376 0 : DO LON_IDX = 1, HcoState%NX
4377 :
4378 : ! If this is a mobilization candidate...
4379 0 : IF ( FLG_MBL(LON_IDX) ) then
4380 :
4381 : ! 19990603: fxm: Dust production is EXTREMELY sensitive to
4382 : ! this parameter, which changes flux by 3 orders of magnitude
4383 : ! in 0.0 < mss_frc_cly < 0.20
4384 0 : MSS_FRC_CLY_VLD = MIN(MSS_FRC_CLY_SLC(LON_IDX),0.2D0) ! [frc]
4385 :
4386 : DST_SLT_FLX_RAT_TTL(LON_IDX) = ! [m-1]
4387 0 : & 100.0D0 * EXP(LN10*(13.4D0*MSS_FRC_CLY_VLD-6.0D0))
4388 : ! MaB95 p. 16423 (47)
4389 :
4390 : FLX_MSS_VRT_DST_TTL(LON_IDX) = ! [kg M-1 s-1]
4391 : & FLX_MSS_HRZ_SLT_TTL(LON_IDX)
4392 0 : & * DST_SLT_FLX_RAT_TTL(LON_IDX)
4393 :
4394 : ENDIF
4395 : ENDDO
4396 :
4397 : ! Return to calling program
4398 0 : END SUBROUTINE FLX_MSS_VRT_DST_TTL_MAB95_GET
4399 :
4400 : !------------------------------------------------------------------------------
4401 :
4402 0 : SUBROUTINE DST_PSD_MSS( OVR_SRC_SNK_FRC, MSS_FRC_SRC,
4403 0 : & OVR_SRC_SNK_MSS, NBINS, DST_SRC_NBR )
4404 : !
4405 : !******************************************************************************
4406 : ! Subroutine DST_PSD_MSS computes OVR_SRC_SNK_MSS from OVR_SRC_SNK_FRC
4407 : ! and MSS_FRC_SRC. (tdf, bmy, 4/5/04)
4408 : !
4409 : ! Multiply ovr_src_snk_frc(src_idx,*) by mss_frc(src_idx) to obtain
4410 : ! absolute mass fraction mapping from source dists. to sink bins
4411 : !
4412 : ! Arguments as Input:
4413 : ! ============================================================================
4414 : ! (1 ) OVR_SRC_SNK_FRC (REAL*8 ) : Mass overlap, Mij, Zender p. 5, Equ. 12
4415 : ! (2 ) MSS_FRC_SRC (REAL*8 ) : Mass fraction in each mode (Table 1, M)
4416 : ! (4 ) NBINS (INTEGER) : Number of GEOS_CHEM dust bins
4417 : ! (5 ) DST_SRC_NBR (INTEGER) : Number of source modes
4418 : !
4419 : ! Arguments as Output:
4420 : ! ============================================================================
4421 : ! (3 ) OVR_SRC_SNK_MSS (REAL*8 ) : Mass of stuff ???
4422 : !
4423 : ! NOTES:
4424 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4425 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4426 : !******************************************************************************
4427 : !
4428 : !-----------------
4429 : ! Arguments
4430 : !-----------------
4431 : INTEGER, INTENT(IN) :: DST_SRC_NBR, NBINS
4432 : REAL*8, INTENT(IN) :: OVR_SRC_SNK_FRC(DST_SRC_NBR,NBINS)
4433 : REAL*8, INTENT(IN) :: MSS_FRC_SRC(DST_SRC_NBR)
4434 : REAL*8, INTENT(OUT) :: OVR_SRC_SNK_MSS(DST_SRC_NBR,NBINS)
4435 :
4436 : !-----------------
4437 : ! Local variables
4438 : !-----------------
4439 : INTEGER :: SRC_IDX, SNK_IDX
4440 0 : REAL*8 :: MSS_FRC_TRN_DST_SRC(NBINS)
4441 : REAL*8 :: OVR_SRC_SNK_MSS_TTL
4442 :
4443 : !=================================================================
4444 : ! DST_PSD_MSS begins here!
4445 : !=================================================================
4446 :
4447 : ! Fraction of vertical dust flux which is transported
4448 0 : OVR_SRC_SNK_MSS_TTL = 0.0D0
4449 :
4450 : ! Fraction of transported dust mass at source
4451 0 : DO SNK_IDX = 1, NBINS
4452 0 : MSS_FRC_TRN_DST_SRC(SNK_IDX) = 0.0D0
4453 : ENDDO
4454 :
4455 0 : DO SNK_IDX = 1, NBINS
4456 0 : DO SRC_IDX = 1, DST_SRC_NBR
4457 0 : OVR_SRC_SNK_MSS (SRC_IDX,SNK_IDX) = ! [frc]
4458 : & OVR_SRC_SNK_FRC (SRC_IDX,SNK_IDX)
4459 0 : & * MSS_FRC_SRC (SRC_IDX) ! [frc]
4460 : ENDDO
4461 : ENDDO
4462 :
4463 : ! Split double do loop into 2 parts tdf 10/22/2K3
4464 0 : DO SNK_IDX = 1, NBINS
4465 0 : DO SRC_IDX = 1, DST_SRC_NBR
4466 :
4467 : ! [frc] Fraction of transported dust mass at source
4468 0 : MSS_FRC_TRN_DST_SRC(SNK_IDX) =
4469 : & MSS_FRC_TRN_DST_SRC(SNK_IDX)
4470 0 : & + OVR_SRC_SNK_MSS(SRC_IDX,SNK_IDX)
4471 :
4472 : ! [frc] Compute total transported mass fraction of dust flux
4473 : OVR_SRC_SNK_MSS_TTL = OVR_SRC_SNK_MSS_TTL
4474 0 : & + OVR_SRC_SNK_MSS (SRC_IDX,snk_idx)
4475 : ENDDO
4476 : ENDDO
4477 :
4478 : ! Convert fraction of mobilized mass to fraction of transported mass
4479 0 : DO SNK_IDX = 1, NBINS
4480 0 : MSS_FRC_TRN_DST_SRC (SNK_IDX) =
4481 0 : & MSS_FRC_TRN_DST_SRC (SNK_IDX) / OVR_SRC_SNK_MSS_TTL
4482 : ENDDO
4483 :
4484 : ! Return to calling program
4485 0 : END SUBROUTINE DST_PSD_MSS
4486 :
4487 : !------------------------------------------------------------------------------
4488 :
4489 0 : SUBROUTINE FLX_MSS_VRT_DST_PRT( Inst, NX, FLG_MBL,
4490 0 : & FLX_MSS_VRT_DST,
4491 0 : & FLX_MSS_VRT_DST_TTL )
4492 : !
4493 : !******************************************************************************
4494 : ! Subroutine FLX_MSS_VRT_DST_PRT partitions total vertical mass flux of dust
4495 : ! into transport bins. Assumes a trimodal lognormal probability density
4496 : ! function (see Zender et al., p. 5). (tdf, bmy, 4/5/04)
4497 : !
4498 : ! DST_SRC_NBR = 3 - trimodal size distribution in source c regions (p. 5)
4499 : ! OVR_SRC_SNK_MSS [frc] computed in dst_psd_mss, called from dust_mod.f
4500 : !
4501 : ! Arguments as Input:
4502 : ! ============================================================================
4503 : ! (1 ) FLG_MBL (LOGICAL) : Mobilization candidate flag
4504 : ! (3 ) FLX_MSS_VRT_DST_TTL (REAL*8 ) : Total vert. mass flux of dust [kg/m2/s]
4505 : !
4506 : ! Arguments as Output:
4507 : ! ============================================================================
4508 : ! (2 ) FLX_MSS_VRT_DST (REAL*8 ) : Vertical mass flux of dust [kg/m2/s]
4509 : !
4510 : ! NOTES:
4511 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4512 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4513 : !******************************************************************************
4514 : !
4515 :
4516 : ! Arguments
4517 : TYPE(MyInst), POINTER :: Inst
4518 : INTEGER, INTENT(IN) :: NX
4519 : LOGICAL, INTENT(IN) :: FLG_MBL(NX)
4520 : REAL*8, INTENT(IN) :: FLX_MSS_VRT_DST_TTL(NX)
4521 : REAL*8, INTENT(OUT) :: FLX_MSS_VRT_DST(NX,NBINS)
4522 :
4523 : ! Local variables
4524 : INTEGER :: LON_IDX ! [idx] Counting index for lon
4525 : INTEGER :: SRC_IDX ! [idx] Counting index for src
4526 : INTEGER :: SNK_IDX ! [idx] Counting index for snk
4527 : INTEGER :: SNK_NBR ! [nbr] Dimension size
4528 :
4529 : !=================================================================
4530 : ! FLX_MSS_VRT_DST_PRT begins here!
4531 : !=================================================================
4532 :
4533 : ! Initialize
4534 0 : FLX_MSS_VRT_DST(:,:) = 0.0D0 ! [frc]
4535 :
4536 : ! Loop over longitudes (NB: Inefficient loop order)
4537 0 : DO LON_IDX = 1, NX
4538 :
4539 : ! If this is a mobilization candidate...
4540 0 : IF ( FLG_MBL(LON_IDX) ) THEN
4541 :
4542 : ! Loop over source & sink indices
4543 0 : DO SNK_IDX = 1, NBINS
4544 0 : DO SRC_IDX = 1, DST_SRC_NBR
4545 0 : FLX_MSS_VRT_DST(LON_IDX,SNK_IDX) = ! [kg m-2 s-1]
4546 : & FLX_MSS_VRT_DST(LON_IDX,SNK_IDX)
4547 0 : & + Inst%OVR_SRC_SNK_MSS(SRC_IDX,SNK_IDX)
4548 0 : & * FLX_MSS_VRT_DST_TTL(LON_IDX)
4549 : ENDDO
4550 : ENDDO
4551 : ENDIF
4552 : ENDDO
4553 :
4554 : ! Return to calling program
4555 0 : END SUBROUTINE FLX_MSS_VRT_DST_PRT
4556 :
4557 : !------------------------------------------------------------------------------
4558 :
4559 : SUBROUTINE TM_2_IDX_WGT()
4560 :
4561 : ! routine eliminated: see original code
4562 : END SUBROUTINE TM_2_IDX_WGT
4563 :
4564 : !------------------------------------------------------------------------------
4565 :
4566 0 : SUBROUTINE LND_FRC_MBL_GET( HcoState, DOY,
4567 0 : & FLG_MBL, LAT_RDN,
4568 0 : & LND_FRC_DRY_SLC, LND_FRC_MBL, MBL_NBR,
4569 0 : & ORO, SFC_TYP_SLC, SNW_FRC,
4570 0 : & TPT_SOI, TPT_SOI_FRZ, VAI_DST_SLC,
4571 : & RC)
4572 : !
4573 : !******************************************************************************
4574 : ! Subroutine LND_FRC_MBL_GET returns the fraction of each GEOS-CHEM grid
4575 : ! box which is suitable for dust mobilization. This routine is called
4576 : ! by DST_MBL. (tdf, bmy, 4/5/04, 1/13/10)
4577 : !
4578 : ! The DATE is used to obtain the time-varying vegetation cover.
4579 : ! Routine currently uses latitude slice of VAI from time-dependent surface
4580 : ! boundary dataset (tdf, 10/27/03). LAI/VAI algorithm is from CCM:lsm/phenol
4581 : ! () Bon96. The LSM data are mid-month values, i.e., valid on the 15th of !
4582 : ! the month.!
4583 : !
4584 : ! Criterion for mobilisation candidate (tdf, 4/5/04):
4585 : ! (1) first, must be a land point, not ocean, not ice
4586 : ! (2) second, it cannot be an inland lake, wetland or ice
4587 : ! (3) modulated by vegetation type
4588 : ! (4) modulated by subgridscale wetness
4589 : ! (5) cannot be snow covered
4590 : !
4591 : ! Arguments as Input:
4592 : ! ============================================================================
4593 : ! (1 ) DOY (REAL*8 ) : Day of year [1.0-366.0]
4594 : ! (3 ) LAT_RDN (REAL*8 ) : Latitude [radians ]
4595 : ! (4 ) LND_FRC_DRY (REAL*8 ) : Dry land fraction [fraction ]
4596 : ! (7 ) ORO (REAL*8 ) : Orography: land/ocean/ice [flags ]
4597 : ! (8 ) SFC_TYP (INTEGER) : LSM surface type (0..28) [unitless ]
4598 : ! (9 ) SNW_FRC (REAL*8 ) : Fraction of surface covered by snow [fraction ]
4599 : ! (10) TPT_SOI (REAL*8 ) : Soil temperature [K ]
4600 : ! (11) TPT_SOI_FRZ (REAL*8 ) : Temperature of frozen soil [K ]
4601 : ! (12) VAI_DST (REAL*8 ) : Vegetation area index, one-sided [m2/m2 ]
4602 : !
4603 : ! Arguments as Output:
4604 : ! ============================================================================
4605 : ! (2 ) FLG_MBL (LOGICAL) : Mobilization candidate flag [flag ]
4606 : ! (5 ) LND_FRC_MBL (REAL*8 ) : Bare ground fraction [fraction ]
4607 : ! (6 ) MBL_NBR (INTEGER) : Number of mobilization candidates [unitless ]
4608 : !
4609 : ! NOTES:
4610 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4611 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4612 : ! (2 ) For the GOCART source function, we don't use VAI, so set FLG_VAI_TVBDS
4613 : ! = .FALSE. and disable calls to ERROR_STOP (tdf, bmy, 1/25/07)
4614 : ! (3 ) Modification for GEOS-4 1 x 1.25 grids (lok, bmy, 1/13/10)
4615 : !******************************************************************************
4616 : !
4617 :
4618 : !------------------
4619 : ! Arguments
4620 : !------------------
4621 : TYPE(HCO_State), POINTER :: HcoState
4622 : INTEGER, INTENT(IN) :: SFC_TYP_SLC(HcoState%NX)
4623 : REAL*8, INTENT(IN) :: DOY
4624 : REAL*8, INTENT(IN) :: LAT_RDN
4625 : REAL*8, INTENT(IN) :: LND_FRC_DRY_SLC(HcoState%NX)
4626 : REAL*8, INTENT(IN) :: ORO(HcoState%NX)
4627 : REAL*8, INTENT(IN) :: SNW_FRC(HcoState%NX)
4628 : REAL*8, INTENT(IN) :: TPT_SOI(HcoState%NX)
4629 : REAL*8, INTENT(IN) :: TPT_SOI_FRZ
4630 : REAL*8, INTENT(IN) :: VAI_DST_SLC(HcoState%NX)
4631 : INTEGER, INTENT(OUT) :: MBL_NBR
4632 : LOGICAL, INTENT(OUT) :: FLG_MBL(HcoState%NX)
4633 : REAL*8, INTENT(OUT) :: LND_FRC_MBL(HcoState%NX)
4634 : INTEGER, INTENT(INOUT) :: RC
4635 :
4636 : !------------------
4637 : ! Parameters
4638 : !------------------
4639 :
4640 : ! VAI threshold quench [m2/m2]
4641 : REAL*8, PARAMETER :: VAI_MBL_THR = 0.30D0
4642 :
4643 : !------------------
4644 : ! Local variables
4645 : !------------------
4646 :
4647 : ! [idx] Counting index
4648 : INTEGER :: IDX_IDX
4649 :
4650 : ! [idx] Interpolation month, future
4651 : INTEGER :: IDX_MTH_GLB
4652 :
4653 : ! [idx] Interpolation month, past
4654 : INTEGER :: IDX_MTH_LUB
4655 :
4656 : ! [idx] Longitude index array (land)
4657 0 : INTEGER :: LND_IDX(HcoState%NX)
4658 :
4659 : ! [nbr] Number of land points
4660 : INTEGER :: LND_NBR
4661 :
4662 : ! [idx] Counting index for longitude
4663 : INTEGER :: LON_IDX
4664 :
4665 : ! [idx] Surface type index
4666 : INTEGER :: SFC_TYP_IDX
4667 :
4668 : ! [idx] Surface sub-gridscale index
4669 : INTEGER :: SGS_IDX
4670 :
4671 : !-------------------------------------------------------------------
4672 : ! Prior to 1/25/07:
4673 : ! For GOCART source function, we don't use VAI (tdf, bmy, 1/25/07)
4674 : !
4675 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
4676 : !
4677 : !! [flg] Use VAI data from time-varying boundary dataset
4678 : ! LOGICAL :: FLG_VAI_TVBDS = .TRUE.
4679 : !-------------------------------------------------------------------
4680 :
4681 : ! For GOCART source function, we do not use VAI (tdf, bmy, 1/25/07)
4682 : LOGICAL :: FLG_VAI_TVBDS = .FALSE.
4683 :
4684 : ! [flg] Add 182 days in southern hemisphere
4685 : LOGICAL :: FLG_SH_ADJ = .TRUE.
4686 :
4687 : ! [dgr] Latitude
4688 : REAL*8 :: LAT_DGR
4689 :
4690 : ! [m2 m-2] Leaf + stem area index, one-sided
4691 : REAL*8 :: VAI_SGS
4692 :
4693 : ! Error handling
4694 : CHARACTER(LEN=255) :: MSG
4695 :
4696 : !=================================================================
4697 : ! LND_FRC_MBL_GET begins here!
4698 : !=================================================================
4699 :
4700 : ! Error check
4701 : IF ( VAI_MBL_THR <= 0.0d0 ) THEN
4702 : MSG = 'VAI_MBL_THR <= 0.0'
4703 : CALL HCO_ERROR(MSG, RC,
4704 : & THISLOC='LND_FRC_MBL_GET' )
4705 : RETURN
4706 : ENDIF
4707 :
4708 : ! Latitude (degrees)
4709 0 : LAT_DGR = 180.0D0 * LAT_RDN/HcoState%Phys%PI
4710 :
4711 : ! Initialize outputs
4712 0 : MBL_NBR = 0
4713 :
4714 0 : DO LON_IDX = 1, HcoState%NX
4715 0 : FLG_MBL(LON_IDX) = .FALSE.
4716 : ENDDO
4717 :
4718 0 : LND_FRC_MBL(:) = 0.0D0
4719 :
4720 : !=================================================================
4721 : ! For dust mobilisation, we need to have land! tdf 10/27/2K3
4722 : ! Set up lnd_idx to hold the longitude indices for land
4723 : ! Land ahoy!
4724 : !=================================================================
4725 0 : LND_NBR = 0
4726 0 : DO LON_IDX = 1, HcoState%NX
4727 0 : IF ( ORO_IS_LND( ORO(LON_IDX)) ) THEN
4728 0 : LND_NBR = LND_NBR + 1
4729 0 : LND_IDX(LND_NBR) = LON_IDX
4730 : ENDIF
4731 : ENDDO
4732 :
4733 : ! Much ado about nothing (no land points)
4734 0 : IF ( LND_NBR == 0 ) RETURN
4735 :
4736 : !-----------------------------------------------------------------------------
4737 : ! Prior to 1/25/07:
4738 : ! When GOCART source function is used, VAI flag is NOT used, so
4739 : ! we need to disable the ERROR_STOP call (tdf, bmy, 1/25/07)
4740 : !
4741 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
4742 : !
4743 : ! ! Introduce error message for flg_vai_tvbds=F (VAI not used!)
4744 : ! IF ( .not. FLG_VAI_TVBDS ) THEN
4745 : !c print *,' FLG_VAI_TVBDS is false: GOCART source function used'
4746 : ! CALL ERROR_STOP( 'FLG_VAI_TVBDS=F',
4747 : ! & 'LND_FRC_MBL_GET ("dust_dead_mod.f")' )
4748 : ! ENDIF
4749 : !-----------------------------------------------------------------------------
4750 :
4751 : !=================================================================
4752 : ! Only land points are possible candidates for dust mobilization
4753 : !=================================================================
4754 :
4755 : ! Loop over land points
4756 0 : DO IDX_IDX = 1, LND_NBR
4757 0 : LON_IDX = LND_IDX(IDX_IDX)
4758 :
4759 : ! Store surface blend of current gridpoint
4760 0 : SFC_TYP_IDX = SFC_TYP_SLC(LON_IDX)
4761 :
4762 : ! Check for wet or frozen conditions - no mobilisation allowed
4763 : ! Surface type 1 = inland lakes & land ice
4764 : ! Surface type 27 = wetlands
4765 0 : IF ( SFC_TYP_IDX <= 1 .OR. SFC_TYP_IDX >= 27 .OR.
4766 : & TPT_SOI(LON_IDX) < TPT_SOI_FRZ ) THEN
4767 :
4768 : ! SET bare ground fraction to zero
4769 0 : LND_FRC_MBL(LON_IDX) = 0.0D0
4770 :
4771 : ELSE
4772 :
4773 : !-------------------------
4774 : ! If we are using VAI...
4775 : !-------------------------
4776 0 : IF ( FLG_VAI_TVBDS ) THEN
4777 :
4778 : ! "bare ground" fraction of current gridcell decreases
4779 : ! linearly from 1.0 to 0.0 as VAI increases from 0.0 to
4780 : ! vai_mbl_thr. NOTE: vai_mbl_thr set to 0.3 (tdf, 4/5/04)
4781 : LND_FRC_MBL(LON_IDX) =
4782 : & 1.0D0 - MIN(1.0D0, MIN(VAI_DST_SLC(LON_IDX),
4783 0 : & VAI_MBL_THR) / VAI_MBL_THR)
4784 :
4785 : !---------------------------
4786 : ! If we're not using VAI...
4787 : !---------------------------
4788 : ELSE
4789 :
4790 : !-----------------------------------------------------------------------------
4791 : ! Prior to 1/25/07:
4792 : ! When GOCART source function is used, VAI flag is NOT used, so
4793 : ! we need to disable the ERROR_STOP call. (tdf, bmy, 1/25/07)
4794 : !
4795 : ! %%%%% DO NOT DELETE -- LEAVE THIS CODE COMMENTED OUT %%%%%
4796 : !
4797 : ! CALL ERROR_STOP( 'FLG_VAI_TVBDS=F',
4798 : ! & 'LND_FRC_MBL_GET ("dust_dead_mod.f")' )
4799 : !-----------------------------------------------------------------------------
4800 :
4801 : ! For GOCART source function, set the bare
4802 : ! ground fraction to 1 (tdf, bmy, 1/25/07)
4803 0 : LND_FRC_MBL(LON_IDX) = 1.0D0
4804 :
4805 : ENDIF
4806 :
4807 : ENDIF ! endif normal land
4808 :
4809 : !==============================================================
4810 : ! We have now filled "lnd_frc_mbl" the land fraction suitable
4811 : ! for mobilisation. Adjust for factors which constrain entire
4812 : ! gridcell LND_FRC_MBL modulated by LND_FRC_DRY and SNW_FRC.
4813 : ! (tdf, 4/5/04)
4814 : !==============================================================
4815 :
4816 : ! Take the bare ground fraction, multiply by the fraction
4817 : ! that is dry and that is NOT covered by snow
4818 : LND_FRC_MBL(LON_IDX) = LND_FRC_MBL(LON_IDX)
4819 : & * LND_FRC_DRY_SLC(LON_IDX)
4820 0 : & * ( 1.0D0 - SNW_FRC(LON_IDX) )
4821 :
4822 : ! Temporary fix for 1 x 1.25 grids -- Lok Lamsal 1/13/10
4823 0 : IF ( LND_FRC_MBL(LON_IDX) .GT. 1.0D0 ) THEN
4824 0 : LND_FRC_MBL(LON_IDX) = 0.99D0
4825 : ENDIF
4826 :
4827 : ! Error check
4828 0 : IF ( LND_FRC_MBL(lon_idx) > 1.0D0 ) THEN
4829 0 : MSG = 'LND_FRC_MBL > 1'
4830 : CALL HCO_ERROR(MSG, RC,
4831 0 : & THISLOC='LND_FRC_MBL_GET' )
4832 0 : RETURN
4833 : ENDIF
4834 :
4835 0 : IF ( LND_FRC_MBL(LON_IDX) < 0.0D0 ) then
4836 0 : MSG = 'LND_FRC_MBL < 0'
4837 : CALL HCO_ERROR(MSG, RC,
4838 0 : & THISLOC='LND_FRC_MBL_GET' )
4839 0 : RETURN
4840 : ENDIF
4841 :
4842 : ! If there is dry land in this longitude
4843 0 : if ( LND_FRC_MBL(LON_IDX) > 0.0D0 ) then
4844 :
4845 : ! Set flag, we have a candidate!
4846 0 : FLG_MBL(LON_IDX) = .TRUE.
4847 :
4848 : ! Increment # of candidates
4849 0 : MBL_NBR = MBL_NBR + 1
4850 : ENDIF
4851 :
4852 : ENDDO
4853 :
4854 : ! Return w/ success
4855 0 : RC = HCO_SUCCESS
4856 :
4857 : ! Return to calling program
4858 : END SUBROUTINE LND_FRC_MBL_GET
4859 :
4860 : !------------------------------------------------------------------------------
4861 :
4862 : SUBROUTINE DST_ADD_LON( NX, NBINS, Q, Q_TTL )
4863 : !
4864 : !******************************************************************************
4865 : ! Subroutine DST_ADD_LON dst_add_lon() computes and returns the total
4866 : ! property (e.g., mixing ratio, flux), obtained by simply adding along the
4867 : ! (dust) constituent dimension, when given an 3-D array of an additive
4868 : ! property (e.g., mixing ratio, flux). (tdf, bmy, 4/5/04)
4869 : !
4870 : ! Arguments as Input:
4871 : ! ============================================================================
4872 : ! (1 ) q (REAL*8) : Total property
4873 : !
4874 : ! Arguments as Output:
4875 : ! ============================================================================
4876 : ! (2 ) q_ttl (REAL*8) : Property for each size class
4877 : !
4878 : ! NOTES:
4879 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4880 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4881 : !******************************************************************************
4882 : !
4883 :
4884 : ! Arguments
4885 : INTEGER, INTENT(IN) :: NX, NBINS
4886 : REAL*8, INTENT(IN) :: Q(NX,NBINS)
4887 : REAL*8, INTENT(OUT) :: Q_TTL(NX)
4888 :
4889 : ! Local variables
4890 : INTEGER :: I, M
4891 :
4892 : !=================================================================
4893 : ! DST_ADD_LON begins here!
4894 : !=================================================================
4895 :
4896 : ! Initialize
4897 : Q_TTL = 0d0
4898 :
4899 : ! Loop over dust bins
4900 : DO M = 1, NBINS
4901 :
4902 : ! Loop over longitudes
4903 : DO I = 1, NX
4904 :
4905 : ! Integrate!
4906 : Q_TTL(I) = Q_TTL(I) + Q(I,M)
4907 :
4908 : ENDDO
4909 : ENDDO
4910 :
4911 : ! Return to calling program
4912 : END SUBROUTINE DST_ADD_LON
4913 :
4914 : !------------------------------------------------------------------------------
4915 :
4916 0 : SUBROUTINE DST_TVBDS_GET( Inst, NX, LAT_IDX, VAI_DST_OUT )
4917 : !
4918 : !******************************************************************************
4919 : ! Subroutine DST_TVBDS_GET returns a specifed latitude slice of VAI data.
4920 : ! (tdf, bmy, 4/5/04)
4921 : !
4922 : ! Arguments as Input:
4923 : ! ============================================================================
4924 : ! (1 ) LAT_IDX (INTEGER) : Latitude index
4925 : !
4926 : ! Arguments as Output:
4927 : ! ============================================================================
4928 : ! (2 ) VAI_DST_OUT (REAL*8 ) : Vegetation area index, 1-sided, current [m2/m2]
4929 : !
4930 : ! NOTES:
4931 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4932 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4933 : !******************************************************************************
4934 : !
4935 :
4936 : ! Arguments
4937 : TYPE(MyInst), POINTER :: Inst
4938 : INTEGER, INTENT(IN) :: NX
4939 : INTEGER, INTENT(IN) :: LAT_IDX
4940 : REAL*8, INTENT(OUT) :: VAI_DST_OUT(:)
4941 :
4942 : ! Local variables
4943 : INTEGER :: LON_IDX
4944 :
4945 : !=================================================================
4946 : ! DST_TVBDS_GET begins here!
4947 : !=================================================================
4948 :
4949 : ! Return lat slice of VAI [m2/m2]
4950 0 : DO LON_IDX = 1, NX
4951 0 : VAI_DST_OUT(LON_IDX) = Inst%VAI_DST(LON_IDX,LAT_IDX)
4952 : ENDDO
4953 :
4954 : ! Return to calling program
4955 0 : END SUBROUTINE DST_TVBDS_GET
4956 :
4957 : !------------------------------------------------------------------------------
4958 :
4959 0 : SUBROUTINE OVR_SRC_SNK_FRC_GET( HcoState,
4960 0 : & SRC_NBR, MDN_SRC,
4961 0 : & GSD_SRC, SNK_NBR,
4962 0 : & DMT_MIN_SNK, DMT_MAX_SNK,
4963 0 : & OVR_SRC_SNK_FRC, RC )
4964 :
4965 : USE HCO_CLOCK_MOD, ONLY : HcoClock_First
4966 : !
4967 : !******************************************************************************
4968 : ! Subroutine OVR_SRC_SNK_FRC_GET, given one set (the "source") of lognormal
4969 : ! distributions, and one set of bin boundaries (the "sink"), computes and
4970 : ! returns the overlap factors between the source distributions and the sink
4971 : ! bins. (tdf, bmy, 4/5/04)
4972 : !
4973 : ! The output is a matrix, Mij, OVR_SRC_SNK_FRC(SRC_NBR,SNK_NBR)
4974 : ! Element ovr_src_snk_frc(i,j) is the fraction of size distribution i
4975 : ! in group src that overlaps sink bin j
4976 : !
4977 : ! Arguments as Input:
4978 : ! ============================================================================
4979 : ! (1 ) SRC_NBR (INTEGER) : Dimension size [unitless]
4980 : ! (2 ) MDN_SRC (REAL*8 ) : Mass median particle size [m ]
4981 : ! (3 ) GSD_SRC (REAL*8 ) : Geometric standard deviation [fraction]
4982 : ! (4 ) SNK_NBR (INTEGER) : Dimension size [unitless]
4983 : ! (5 ) DMT_MIN_SNK (REAL*8 ) : Minimum diameter in bin [m ]
4984 : ! (6 ) DMT_MAX_SNK (REAL*8 ) : Maximum diameter in bin [m ]
4985 : !
4986 : ! Arguments as Output:
4987 : ! ============================================================================
4988 : ! (7 ) OVR_SRC_SNK_FRC (REAL*8 ) : Fractional overlap of src with snk, Mij.
4989 : !
4990 : ! NOTES
4991 : ! (1 ) Updated comments, cosmetic changes. Also now forces double-precision
4992 : ! with "D" exponents. (tdf, bmy, 4/5/04)
4993 : !******************************************************************************
4994 : !
4995 :
4996 : ! Arguments
4997 : TYPE(HCO_State), POINTER :: HcoState
4998 : INTEGER, INTENT(IN) :: SRC_NBR
4999 : REAL*8, INTENT(IN) :: MDN_SRC(SRC_NBR)
5000 : REAL*8, INTENT(IN) :: GSD_SRC(SRC_NBR)
5001 : INTEGER, INTENT(IN) :: SNK_NBR
5002 : REAL*8, INTENT(IN) :: DMT_MIN_SNK(SNK_NBR)
5003 : REAL*8, INTENT(IN) :: DMT_MAX_SNK(SNK_NBR)
5004 : REAL*8, INTENT(OUT) :: OVR_SRC_SNK_FRC(SRC_NBR,SNK_NBR)
5005 : INTEGER, INTENT(INOUT) :: RC
5006 :
5007 : ! Local
5008 : ! LOGICAL :: FIRST = .TRUE.
5009 : INTEGER :: SRC_IDX ! [idx] Counting index for src
5010 : INTEGER :: SNK_IDX ! [idx] Counting index for snk
5011 : REAL*8 :: LN_GSD ! [frc] ln(gsd)
5012 : REAL*8 :: SQRT2LNGSDI ! [frc] Factor in erf() argument
5013 : REAL*8 :: LNDMAXJOVRDMDNI ! [frc] Factor in erf() argument
5014 : REAL*8 :: LNDMINJOVRDMDNI ! [frc] Factor in erf() argument
5015 : CHARACTER(LEN=255) :: MSG
5016 :
5017 : !=================================================================
5018 : ! OVR_SRC_SNK_FRC_GET begins here
5019 : !=================================================================
5020 :
5021 0 : IF ( HcoClock_First(HcoState%Clock,.TRUE.) ) THEN
5022 :
5023 : ! Test if ERF is implemented OK on this platform
5024 : ! 19990913: erf() in SGI /usr/lib64/mips4/libftn.so is bogus
5025 0 : IF ( ABS( 0.8427d0 - ERF(1.0d0) ) / 0.8427d0 > 0.001d0 ) THEN
5026 0 : MSG = 'ERF error 1 in OVR_SRC_SNK_FRC_GET!'
5027 : CALL HCO_ERROR(MSG, RC,
5028 0 : & THISLOC='OVR_SRC_SNK_FRC_GET' )
5029 0 : RETURN
5030 : ENDIF
5031 :
5032 : ! Another ERF check
5033 0 : IF ( ERF( 0.0D0 ) /= 0.0D0 ) THEN
5034 0 : MSG = 'ERF error 2 in OVR_SRC_SNK_FRC_GET!'
5035 : CALL HCO_ERROR(MSG, RC,
5036 0 : & THISLOC='OVR_SRC_SNK_FRC_GET' )
5037 0 : RETURN
5038 : ENDIF
5039 :
5040 : ! Reset first-time flag
5041 : !FIRST = .FALSE.
5042 : ENDIF
5043 :
5044 :
5045 : ! Loop over source index (cf Zender et al eq 12)
5046 0 : DO SRC_IDX = 1, SRC_NBR
5047 :
5048 : ! Fraction
5049 0 : SQRT2LNGSDI = SQRT(2.0D0) * LOG( GSD_SRC(SRC_IDX) )
5050 :
5051 : ! Loop over sink index
5052 0 : DO SNK_IDX = 1, SNK_NBR
5053 :
5054 : ! [fraction]
5055 0 : LNDMAXJOVRDMDNI = LOG(DMT_MAX_SNK(SNK_IDX)/MDN_SRC(SRC_IDX))
5056 :
5057 : ! [fraction]
5058 0 : LNDMINJOVRDMDNI = LOG(DMT_MIN_SNK(SNK_IDX)/MDN_SRC(SRC_IDX))
5059 :
5060 : ! [fraction]
5061 : OVR_SRC_SNK_FRC (SRC_IDX,SNK_IDX)= ! [frc]
5062 : & 0.5D0 * (ERF(LNDMAXJOVRDMDNI/SQRT2LNGSDI)
5063 0 : & - ERF(LNDMINJOVRDMDNI/SQRT2LNGSDI) )
5064 : ENDDO
5065 : ENDDO
5066 :
5067 : ! Return w/ success
5068 0 : RC = HCO_SUCCESS
5069 :
5070 : END SUBROUTINE OVR_SRC_SNK_FRC_GET
5071 :
5072 : !------------------------------------------------------------------------------
5073 :
5074 0 : FUNCTION ERF( X ) RESULT( ERF_VAL )
5075 : !
5076 : !******************************************************************************
5077 : ! Function ERF returns the error function erf(x). See comments heading
5078 : ! routine CALERF below. Author/Date: W. J. Cody, January 8, 1985
5079 : ! (tdf, bmy, 4/5/04)
5080 : !
5081 : ! Arguments as Input:
5082 : ! ============================================================================
5083 : ! (1 ) X (REAL*8) : Argument to erf(x)
5084 : !
5085 : ! NOTES:
5086 : ! (1 ) Updated comments (bmy, 4/5/04)
5087 : !******************************************************************************
5088 : !
5089 : IMPLICIT NONE
5090 :
5091 : ! Arguments
5092 : REAL*8, INTENT(IN) :: X
5093 :
5094 : ! Local variables
5095 : INTEGER :: JINT
5096 : REAL*8 :: RESULT, ERF_VAL
5097 :
5098 : !================================================================
5099 : ! ERF begins here!
5100 : !================================================================
5101 0 : JINT = 0
5102 0 : CALL CALERF( X, RESULT, JINT )
5103 0 : ERF_VAL = RESULT
5104 :
5105 : ! Return to calling program
5106 0 : END FUNCTION ERF
5107 :
5108 : !------------------------------------------------------------------------------
5109 :
5110 0 : SUBROUTINE CALERF( ARG, RESULT, JINT )
5111 : !
5112 : !******************************************************************************
5113 : ! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x)
5114 : ! for a real argument x. It contains three function type
5115 : ! subprograms: erf, erfc, and erfcx (or derf, derfc, and derfcx),
5116 : ! and one subroutine type subprogram, calerf. The calling
5117 : ! statements for the primary entries are:
5118 : !
5119 : ! y=erf(x) (or y=derf(x)),
5120 : ! y=erfc(x) (or y=derfc(x)),
5121 : ! and
5122 : ! y=erfcx(x) (or y=derfcx(x)).
5123 : !
5124 : ! The routine calerf is intended for internal packet use only,
5125 : ! all computations within the packet being concentrated in this
5126 : ! routine. The function subprograms invoke calerf with the
5127 : ! statement
5128 : ! call calerf(arg,result,jint)
5129 : ! where the parameter usage is as follows
5130 : !
5131 : ! Function Parameters for calerf
5132 : ! Call Arg Result Jint
5133 : !
5134 : ! erf(arg) any real argument erf(arg) 0
5135 : ! erfc(arg) abs(arg) < xbig erfc(arg) 1
5136 : ! erfcx(arg) xneg < arg < xmax erfcx(arg) 2
5137 : !
5138 : ! The main computation evaluates near-minimax approximations:
5139 : ! from "Rational Chebyshev Approximations for the Error Function"
5140 : ! by W. J. Cody, Math. Comp., 1969, pp. 631-638. This
5141 : ! transportable program uses rational functions that theoretically
5142 : ! approximate erf(x) and erfc(x) to at least 18 significant
5143 : ! decimal digits. The accuracy achieved depends on the arithmetic
5144 : ! system, the compiler, the intrinsic functions, and proper
5145 : ! selection of the machine-dependent constants.
5146 : !
5147 : ! Explanation of machine-dependent constants:
5148 : ! xmin = The smallest positive floating-point number.
5149 : ! xinf = The largest positive finite floating-point number.
5150 : ! xneg = The largest negative argument acceptable to erfcx;
5151 : ! the negative of the solution to the equation
5152 : ! 2*exp(x*x) = xinf.
5153 : ! xsmall = Argument below which erf(x) may be represented by
5154 : ! 2*x/sqrt(pi) and above which x*x will not underflow.
5155 : ! A conservative value is the largest machine number x
5156 : ! such that 1.0 + x = 1.0 to machine precision.
5157 : ! xbig = Largest argument acceptable to erfc; solution to
5158 : ! the equation: w(x)* (1-0.5/x**2) = xmin, where
5159 : ! w(x) = exp(-x*x)/[x*sqrt(pi)].
5160 : ! xhuge = Argument above which 1.0 - 1/(2*x*x) = 1.0 to
5161 : ! machine precision. a conservative value is
5162 : ! 1/[2*sqrt(xsmall)]
5163 : ! xmax = Largest acceptable argument to erfcx; the minimum
5164 : ! of xinf and 1/[sqrt(pi)*xmin].
5165 : !
5166 : ! Approximate values for some important machines are:
5167 : ! xmin xinf xneg xsmall
5168 : ! CDC 7600 (s.p.) 3.13e-294 1.26e+322 -27.220 7.11e-15
5169 : ! Cray-1 (s.p.) 4.58e-2467 5.45e+2465 -75.345 7.11e-15
5170 : ! IEEE (IBM/XT,
5171 : ! Sun, etc.) (s.p.) 1.18e-38 3.40e+38 -9.382 5.96e-8
5172 : ! IEEE (IBM/XT,
5173 : ! Sun, etc.) (d.p.) 2.23d-308 1.79d+308 -26.628 1.11d-16
5174 : ! IBM 195 (d.p.) 5.40d-79 7.23e+75 -13.190 1.39d-17
5175 : ! Univac 1108 (d.p.) 2.78d-309 8.98d+307 -26.615 1.73d-18
5176 : ! Vax d-format (d.p.) 2.94d-39 1.70d+38 -9.345 1.39d-17
5177 : ! Vax g-format (d.p.) 5.56d-309 8.98d+307 -26.615 1.11d-16
5178 : !
5179 : ! xbig xhuge xmax
5180 : ! CDC 7600 (s.p.) 25.922 8.39e+6 1.80x+293
5181 : ! Cray-1 (s.p.) 75.326 8.39e+6 5.45e+2465
5182 : ! IEEE (IBM/XT,
5183 : ! Sun, etc.) (s.p.) 9.194 2.90e+3 4.79e+37
5184 : ! IEEE (IBM/XT,
5185 : ! Sun, etc.) (d.p.) 26.543 6.71d+7 2.53d+307
5186 : ! IBM 195 (d.p.) 13.306 1.90d+8 7.23e+75
5187 : ! Univac 1108 (d.p.) 26.582 5.37d+8 8.98d+307
5188 : ! Vax d-format (d.p.) 9.269 1.90d+8 1.70d+38
5189 : ! Vax g-format (d.p.) 26.569 6.71d+7 8.98d+307
5190 : !
5191 : ! Error returns:
5192 : ! The program returns erfc = 0 for arg >= xbig;
5193 : ! erfcx = xinf for arg < xneg;
5194 : ! and
5195 : ! erfcx = 0 for arg >= xmax.
5196 : !
5197 : ! Intrinsic functions required are:
5198 : ! abs, aint, exp
5199 : !
5200 : ! Author: W. J. Cody
5201 : ! Mathematics And Computer Science Division
5202 : ! Argonne National Laboratory
5203 : ! Argonne, IL 60439
5204 : ! Latest modification: March 19, 1990
5205 : !
5206 : ! NOTES:
5207 : ! (1 ) Now force double-precision w/ "D" exponents (bmy, 4/5/04)
5208 : !******************************************************************************
5209 : !
5210 : IMPLICIT NONE
5211 : INTEGER I,JINT
5212 : REAL*8 A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEN,SQRPI,
5213 : & TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL,
5214 : & Y,YSQ,ZERO
5215 : DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5)
5216 :
5217 : ! Mathematical constants
5218 : data four,one,half,two,zero/4.0d0,1.0d0,0.5d0,2.0d0,0.0d0/,
5219 : & sqrpi/5.6418958354775628695d-1/,thresh/0.46875d0/,
5220 : & sixten/16.0d0/
5221 :
5222 : ! Machine-dependent constants
5223 : data xinf,xneg,xsmall/3.40d+38,-9.382d0,5.96d-8/,
5224 : & xbig,xhuge,xmax/9.194d0,2.90d3,4.79d37/
5225 :
5226 : ! Coefficients for approximation to erf in first interval
5227 : data a /3.16112374387056560d00,1.13864154151050156d02,
5228 : & 3.77485237685302021d02,3.20937758913846947d03,
5229 : & 1.85777706184603153d-1/
5230 :
5231 : data b /2.36012909523441209d01,2.44024637934444173d02,
5232 : & 1.28261652607737228d03,2.84423683343917062d03/
5233 :
5234 : ! Coefficients for approximation to erfc in second interval
5235 : data c /5.64188496988670089d-1,8.88314979438837594d0,
5236 : & 6.61191906371416295d01,2.98635138197400131d02,
5237 : & 8.81952221241769090d02,1.71204761263407058d03,
5238 : & 2.05107837782607147d03,1.23033935479799725d03,
5239 : & 2.15311535474403846d-8/
5240 :
5241 : data d /1.57449261107098347d01,1.17693950891312499d02,
5242 : & 5.37181101862009858d02,1.62138957456669019d03,
5243 : & 3.29079923573345963d03,4.36261909014324716d03,
5244 : & 3.43936767414372164d03,1.23033935480374942d03/
5245 :
5246 : ! Coefficients for approximation to erfc in third interval
5247 : data p /3.05326634961232344d-1,3.60344899949804439d-1,
5248 : & 1.25781726111229246d-1,1.60837851487422766d-2,
5249 : & 6.58749161529837803d-4,1.63153871373020978d-2/
5250 :
5251 : data q /2.56852019228982242d00,1.87295284992346047d00,
5252 : & 5.27905102951428412d-1,6.05183413124413191d-2,
5253 : & 2.33520497626869185d-3/
5254 :
5255 : c Main Code
5256 0 : x=arg
5257 0 : y=abs(x)
5258 0 : if (y <= thresh) then
5259 : c Evaluate erf for |x| <= 0.46875
5260 0 : ysq=zero
5261 0 : if (y > xsmall) ysq=y*y
5262 0 : xnum=a(5)*ysq
5263 0 : xden=ysq
5264 0 : do i=1,3
5265 0 : xnum=(xnum+a(i))*ysq
5266 0 : xden=(xden+b(i))*ysq
5267 : end do
5268 0 : result=x*(xnum+a(4))/(xden+b(4))
5269 0 : if (jint /= 0) result=one-result
5270 0 : if (jint == 2) result=exp(ysq)*result
5271 : go to 800
5272 :
5273 : c Evaluate erfc for 0.46875 <= |x| <= 4.0
5274 0 : else if (y <= four) then
5275 0 : xnum=c(9)*y
5276 0 : xden=y
5277 0 : do i=1,7
5278 0 : xnum=(xnum+c(i))*y
5279 0 : xden=(xden+d(i))*y
5280 : end do
5281 0 : result=(xnum+c(8))/(xden+d(8))
5282 0 : if (jint /= 2) then
5283 0 : ysq=aint(y*sixten)/sixten
5284 0 : del=(y-ysq)*(y+ysq)
5285 0 : result=exp(-ysq*ysq)*exp(-del)*result
5286 : end if
5287 :
5288 : c Evaluate erfc for |x| > 4.0
5289 : else
5290 0 : result=zero
5291 0 : if (y >= xbig) then
5292 0 : if ((jint /= 2).or.(y >= xmax)) go to 300
5293 0 : if (y >= xhuge) then
5294 0 : result=sqrpi/y
5295 0 : go to 300
5296 : end if
5297 : end if
5298 0 : ysq=one/(y*y)
5299 0 : xnum=p(6)*ysq
5300 0 : xden=ysq
5301 0 : do i=1,4
5302 0 : xnum=(xnum+p(i))*ysq
5303 0 : xden=(xden+q(i))*ysq
5304 : end do
5305 0 : result=ysq*(xnum+p(5))/(xden+q(5))
5306 0 : result=(sqrpi-result)/y
5307 0 : if (jint /= 2) then
5308 0 : ysq=aint(y*sixten)/sixten
5309 0 : del=(y-ysq)*(y+ysq)
5310 0 : result=exp(-ysq*ysq)*exp(-del)*result
5311 : end if
5312 : end if
5313 :
5314 : c Fix up for negative argument, erf, etc.
5315 0 : 300 if (jint == 0) then
5316 0 : result=(half-result)+half
5317 0 : if (x < zero) result=-result
5318 0 : else if (jint == 1) then
5319 0 : if (x < zero) result=two-result
5320 : else
5321 0 : if (x < zero) then
5322 0 : if (x < xneg) then
5323 0 : result=xinf
5324 : else
5325 0 : ysq=aint(x*sixten)/sixten
5326 0 : del=(x-ysq)*(x+ysq)
5327 0 : y=exp(ysq*ysq)*exp(del)
5328 0 : result=(y+y)-result
5329 : end if
5330 : end if
5331 : end if
5332 0 : 800 return
5333 :
5334 : ! Return to calling program
5335 : END SUBROUTINE CALERF
5336 :
5337 : !------------------------------------------------------------------------------
5338 :
5339 0 : SUBROUTINE PLN_TYP_GET( PLN_TYP, PLN_FRC, TAI )
5340 :
5341 : !
5342 : !******************************************************************************
5343 : ! Subroutine PLN_TYPE_GET returns LSM information needed by the DEAD
5344 : ! dust parameterization. (tdf, bmy, 4/5/04)
5345 : !
5346 : ! Arguments as Output:
5347 : ! ============================================================================
5348 : ! (1 ) PLN_TYP (INTEGER) : LSM plant type index (1..14)
5349 : ! (2 ) PLN_TYP (REAL*8 ) : Weight of corresponding plant type (sums to 1.0)
5350 : ! (3 ) TAI (REAL*8 ) : Leaf-area index (one sided) [index]
5351 : !
5352 : ! NOTES:
5353 : ! (1 ) Updated comments. Now force double-precision w/ "D" exponents.
5354 : ! (bmy, 4/5/04)
5355 : !******************************************************************************
5356 : !
5357 : ! Arguments
5358 : INTEGER, INTENT(OUT) :: PLN_TYP(0:28,3)
5359 : REAL*8, INTENT(OUT) :: PLN_FRC(0:28,3)
5360 : REAL*8, INTENT(OUT) :: TAI(14,12)
5361 :
5362 : ! Local variables
5363 : INTEGER :: I, J
5364 :
5365 : !=================================================================
5366 : ! There are 29 land surface types: 0 = ocean, 1 to 28 = land.
5367 : ! Each land point has up to three vegetation types, ranging in
5368 : ! value from 1 to 14. PLN_TYPE contains the vegetation type of
5369 : ! the 3 subgrid points for each surface type. PLN_FRC contains
5370 : ! the fractional area of the 3 subgrid points for each surface
5371 : ! type.
5372 : !=================================================================
5373 : PLN_TYP(0:28,1) = (/ 0,
5374 : & 14, 14, 1, 2, 4, 1 , 1,
5375 : & 4, 1, 3, 5, 13, 1, 2,
5376 : & 11, 11, 6, 13, 9, 7, 8,
5377 0 : & 8, 12, 11, 12, 11, 3, 14/)
5378 :
5379 : PLN_FRC(0:28,1) = (/ 0.00d0,
5380 : & 1.00d0, 1.00d0, 0.75d0, 0.50d0,
5381 : & 0.75d0, 0.37d0, 0.75d0,
5382 : & 0.75d0, 0.37d0, 0.95d0, 0.75d0,
5383 : & 0.70d0, 0.25d0, 0.25d0,
5384 : & 0.40d0, 0.40d0, 0.60d0, 0.60d0,
5385 : & 0.30d0, 0.80d0, 0.80d0,
5386 : & 0.10d0, 0.85d0, 0.85d0, 0.85d0,
5387 0 : & 0.85d0, 0.80d0, 1.00d0/)
5388 :
5389 :
5390 : PLN_TYP(0:28,2) = (/ 0,
5391 : & 14, 14, 14, 14, 14, 4 ,14,
5392 : & 14, 4, 14, 14, 5, 10, 10,
5393 : & 4, 4, 13, 6, 10, 14, 14,
5394 0 : & 14, 14, 14, 14, 14, 14, 14/)
5395 :
5396 : PLN_FRC(0:28,2) = (/ 0.00d0,
5397 : & 0.00d0, 0.00d0, 0.25d0, 0.50d0,
5398 : & 0.25d0, 0.37d0, 0.25d0,
5399 : & 0.25d0, 0.37d0, 0.05d0, 0.25d0,
5400 : & 0.30d0, 0.25d0, 0.25d0,
5401 : & 0.30d0, 0.30d0, 0.20d0, 0.20d0,
5402 : & 0.30d0, 0.20d0, 0.20d0,
5403 : & 0.90d0, 0.15d0, 0.15d0, 0.15d0,
5404 0 : & 0.15d0, 0.20d0, 0.00d0/)
5405 :
5406 : PLN_TYP(0:28,3) = (/ 0,
5407 : & 14, 14, 14, 14, 14, 14, 14,
5408 : & 14, 14, 14, 14, 14, 14, 14,
5409 : & 1, 1, 14, 14, 14, 14, 14,
5410 0 : & 14, 14, 14, 14, 14, 14, 14/)
5411 :
5412 : PLN_FRC(0:28,3) = (/ 0.00d0,
5413 : & 0.00d0, 0.00d0, 0.00d0, 0.00d0,
5414 : & 0.00d0, 0.26d0, 0.00d0,
5415 : & 0.00d0, 0.26d0, 0.00d0, 0.00d0,
5416 : & 0.00d0, 0.50d0, 0.50d0,
5417 : & 0.30d0, 0.30d0, 0.20d0, 0.20d0,
5418 : & 0.40d0, 0.00d0, 0.00d0,
5419 : & 0.00d0, 0.00d0, 0.00d0, 0.00d0,
5420 0 : & 0.00d0, 0.00d0, 0.00d0/)
5421 :
5422 : !=================================================================
5423 : ! ----------------------------------------------------------------
5424 : ! description of the 29 surface types
5425 : ! ----------------------------------------------------------------
5426 : !
5427 : ! no vegetation
5428 : ! -------------
5429 : ! 0 ocean
5430 : ! 1 land ice (glacier)
5431 : ! 2 desert
5432 : !
5433 : ! forest vegetation
5434 : ! -----------------
5435 : ! 3 cool needleleaf evergreen tree
5436 : ! 4 cool needleleaf deciduous tree
5437 : ! 5 cool broadleaf deciduous tree
5438 : ! 6 cool mixed needleleaf evergreen and broadleaf deciduous tree
5439 : ! 7 warm needleleaf evergreen tree
5440 : ! 8 warm broadleaf deciduous tree
5441 : ! 9 warm mixed needleleaf evergreen and broadleaf deciduous tree
5442 : ! 10 tropical broadleaf evergreen tree
5443 : ! 11 tropical seasonal deciduous tree
5444 : !
5445 : ! interrupted woods
5446 : ! ----------------
5447 : ! 12 savanna
5448 : ! 13 evergreen forest tundra
5449 : ! 14 deciduous forest tundra
5450 : ! 15 cool forest crop
5451 : ! 16 warm forest crop
5452 : !
5453 : ! non-woods
5454 : ! ---------
5455 : ! 17 cool grassland
5456 : ! 18 warm grassland
5457 : ! 19 tundra
5458 : ! 20 evergreen shrub
5459 : ! 21 deciduous shrub
5460 : ! 22 semi-desert
5461 : ! 23 cool irrigated crop
5462 : ! 24 cool non-irrigated crop
5463 : ! 25 warm irrigated crop
5464 : ! 26 warm non-irrigated crop
5465 : !
5466 : ! wetlands
5467 : ! --------
5468 : ! 27 forest (mangrove)
5469 : ! 28 non-forest
5470 : !
5471 : ! ----------------------------------------------------------------
5472 : ! description of the 14 plant types. see vegconi.F for
5473 : ! parameters that depend on vegetation type
5474 : ! ----------------------------------------------------------------
5475 : !
5476 : ! 1 = needleleaf evergreen tree
5477 : ! 2 = needleleaf deciduous tree
5478 : ! 3 = broadleaf evergreen tree
5479 : ! 4 = broadleaf deciduous tree
5480 : ! 5 = tropical seasonal tree
5481 : ! 6 = cool grass (c3)
5482 : ! 7 = evergreen shrub
5483 : ! 8 = deciduous shrub
5484 : ! 9 = arctic deciduous shrub
5485 : ! 10 = arctic grass
5486 : ! 11 = crop
5487 : ! 12 = irrigated crop
5488 : ! 13 = warm grass (c4)
5489 : ! 14 = not vegetated
5490 : !=================================================================
5491 :
5492 : ! TAI = monthly leaf area index + stem area index, one-sided
5493 : TAI(1,1:12) = (/ 4.5d0, 4.7d0, 5.0d0, 5.1d0, 5.3d0, 5.5d0,
5494 0 : & 5.3d0, 5.3d0, 5.2d0, 4.9d0, 4.6d0, 4.5d0 /)
5495 :
5496 : TAI(2,1:12) = (/ 0.3d0, 0.3d0, 0.3d0, 1.0d0, 1.6d0, 2.4d0,
5497 0 : & 4.3d0, 2.9d0, 2.0d0, 1.3d0, 0.8d0, 0.5d0 /)
5498 :
5499 : TAI(3,1:12) = (/ 5.0d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0,
5500 0 : & 5.0d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0 /)
5501 :
5502 : TAI(4,1:12) = (/ 0.4d0, 0.4d0, 0.7d0, 1.6d0, 3.5d0, 5.1d0,
5503 0 : & 5.4d0, 4.8d0, 3.8d0, 1.7d0, 0.6d0, 0.4d0 /)
5504 :
5505 : TAI(5,1:12) = (/ 1.2d0, 1.0d0, 0.9d0, 0.8d0, 0.8d0, 1.0d0,
5506 0 : & 2.0d0, 3.7d0, 3.2d0, 2.7d0, 1.9d0, 1.2d0 /)
5507 :
5508 : TAI(6,1:12) = (/ 0.7d0, 0.8d0, 0.9d0, 1.0d0, 1.5d0, 3.4d0,
5509 0 : & 4.3d0, 3.8d0, 1.8d0, 1.0d0, 0.9d0, 0.8d0 /)
5510 :
5511 : TAI(7,1:12) = (/ 1.3d0, 1.3d0, 1.3d0, 1.3d0, 1.3d0, 1.3d0,
5512 0 : & 1.3d0, 1.3d0, 1.3d0, 1.3d0, 1.3d0, 1.3d0 /)
5513 :
5514 : TAI(8,1:12) = (/ 1.0d0, 1.0d0, 0.8d0, 0.3d0, 0.6d0, 0.0d0,
5515 0 : & 0.1d0, 0.3d0, 0.5d0, 0.6d0, 0.7d0, 0.9d0 /)
5516 :
5517 : TAI(9,1:12) = (/ 0.1d0, 0.1d0, 0.1d0, 0.1d0, 0.1d0, 0.3d0,
5518 0 : & 1.5d0, 1.7d0, 1.4d0, 0.1d0, 0.1d0, 0.1d0 /)
5519 :
5520 : TAI(10,1:12) = (/ 0.7d0, 0.8d0, 0.9d0, 1.0d0, 1.5d0, 3.4d0,
5521 0 : & 4.3d0, 3.8d0, 1.8d0, 1.0d0, 0.9d0, 0.8d0 /)
5522 :
5523 : TAI(11,1:12) = (/ 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0, 2.0d0,
5524 0 : & 3.0d0, 3.0d0, 1.5d0, 0.0d0, 0.0d0, 0.0d0 /)
5525 :
5526 : TAI(12,1:12) = (/ 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0, 2.0d0,
5527 0 : & 3.0d0, 3.0d0, 1.5d0, 0.0d0, 0.0d0, 0.0d0 /)
5528 :
5529 : TAI(13,1:12) = (/ 0.7d0, 0.8d0, 0.9d0, 1.0d0, 1.5d0, 3.4d0,
5530 0 : & 4.3d0, 3.8d0, 1.8d0, 1.0d0, 0.9d0, 0.8d0 /)
5531 :
5532 : TAI(14,1:12) = (/ 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
5533 0 : & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0 /)
5534 :
5535 : ! Return to calling program
5536 0 : END SUBROUTINE PLN_TYP_GET
5537 :
5538 : !******************************************************************************
5539 : !------------------------------------------------------------------------------
5540 : ! Harmonized Emissions Component (HEMCO) !
5541 : !------------------------------------------------------------------------------
5542 : !BOP
5543 : !
5544 : ! !IROUTINE: InstGet
5545 : !
5546 : ! !DESCRIPTION: Subroutine InstGet returns a pointer to the desired instance.
5547 : !\\
5548 : !\\
5549 : ! !INTERFACE:
5550 : !
5551 0 : SUBROUTINE InstGet ( Instance, Inst, RC, PrevInst )
5552 : !
5553 : ! !INPUT PARAMETERS:
5554 : !
5555 : INTEGER :: Instance
5556 : TYPE(MyInst), POINTER :: Inst
5557 : INTEGER :: RC
5558 : TYPE(MyInst), POINTER, OPTIONAL :: PrevInst
5559 : !
5560 : ! !REVISION HISTORY:
5561 : ! 18 Feb 2016 - C. Keller - Initial version
5562 : ! See https://github.com/geoschem/hemco for complete history
5563 : !EOP
5564 : !------------------------------------------------------------------------------
5565 : !BOC
5566 : TYPE(MyInst), POINTER :: PrvInst
5567 :
5568 : !=================================================================
5569 : ! InstGet begins here!
5570 : !=================================================================
5571 :
5572 : ! Get instance. Also archive previous instance.
5573 0 : PrvInst => NULL()
5574 0 : Inst => AllInst
5575 0 : DO WHILE ( ASSOCIATED(Inst) )
5576 0 : IF ( Inst%Instance == Instance ) EXIT
5577 0 : PrvInst => Inst
5578 0 : Inst => Inst%NextInst
5579 : END DO
5580 0 : IF ( .NOT. ASSOCIATED( Inst ) ) THEN
5581 0 : RC = HCO_FAIL
5582 0 : RETURN
5583 : ENDIF
5584 :
5585 : ! Pass output arguments
5586 0 : IF ( PRESENT(PrevInst) ) PrevInst => PrvInst
5587 :
5588 : ! Cleanup & Return
5589 0 : PrvInst => NULL()
5590 0 : RC = HCO_SUCCESS
5591 :
5592 : END SUBROUTINE InstGet
5593 : !EOC
5594 : !------------------------------------------------------------------------------
5595 : ! Harmonized Emissions Component (HEMCO) !
5596 : !------------------------------------------------------------------------------
5597 : !BOP
5598 : !
5599 : ! !IROUTINE: InstCreate
5600 : !
5601 : ! !DESCRIPTION: Subroutine InstCreate creates a new instance.
5602 : !\\
5603 : !\\
5604 : ! !INTERFACE:
5605 : !
5606 0 : SUBROUTINE InstCreate ( ExtNr, Instance, Inst, RC )
5607 : !
5608 : ! !INPUT PARAMETERS:
5609 : !
5610 : INTEGER, INTENT(IN) :: ExtNr
5611 : !
5612 : ! !OUTPUT PARAMETERS:
5613 : !
5614 : INTEGER, INTENT( OUT) :: Instance
5615 : TYPE(MyInst), POINTER :: Inst
5616 : !
5617 : ! !INPUT/OUTPUT PARAMETERS:
5618 : !
5619 : INTEGER, INTENT(INOUT) :: RC
5620 : !
5621 : ! !REVISION HISTORY:
5622 : ! 18 Feb 2016 - C. Keller - Initial version
5623 : ! See https://github.com/geoschem/hemco for complete history
5624 : !EOP
5625 : !------------------------------------------------------------------------------
5626 : !BOC
5627 : TYPE(MyInst), POINTER :: TmpInst
5628 : INTEGER :: nnInst
5629 :
5630 : !=================================================================
5631 : ! InstCreate begins here!
5632 : !=================================================================
5633 :
5634 : ! ----------------------------------------------------------------
5635 : ! Generic instance initialization
5636 : ! ----------------------------------------------------------------
5637 :
5638 : ! Initialize
5639 0 : Inst => NULL()
5640 :
5641 : ! Get number of already existing instances
5642 0 : TmpInst => AllInst
5643 0 : nnInst = 0
5644 0 : DO WHILE ( ASSOCIATED(TmpInst) )
5645 0 : nnInst = nnInst + 1
5646 0 : TmpInst => TmpInst%NextInst
5647 : END DO
5648 :
5649 : ! Create new instance
5650 0 : ALLOCATE(Inst)
5651 0 : Inst%Instance = nnInst + 1
5652 0 : Inst%ExtNr = ExtNr
5653 :
5654 : ! Attach to instance list
5655 0 : Inst%NextInst => AllInst
5656 0 : AllInst => Inst
5657 :
5658 : ! Update output instance
5659 0 : Instance = Inst%Instance
5660 :
5661 : ! ----------------------------------------------------------------
5662 : ! Type specific initialization statements follow below
5663 : ! ----------------------------------------------------------------
5664 0 : Inst%ERD_FCT_GEO => NULL()
5665 0 : Inst%SRCE_FUNC => NULL()
5666 0 : Inst%LND_FRC_DRY => NULL()
5667 0 : Inst%MSS_FRC_CACO3 => NULL()
5668 0 : Inst%MSS_FRC_SND => NULL()
5669 0 : Inst%SFC_TYP => NULL()
5670 0 : Inst%VAI_DST => NULL()
5671 :
5672 : ! Return w/ success
5673 0 : RC = HCO_SUCCESS
5674 :
5675 0 : END SUBROUTINE InstCreate
5676 : !EOC
5677 : !------------------------------------------------------------------------------
5678 : ! Harmonized Emissions Component (HEMCO) !
5679 : !------------------------------------------------------------------------------
5680 : !BOP
5681 : !
5682 : ! !IROUTINE: InstRemove
5683 : !
5684 : ! !DESCRIPTION: Subroutine InstRemove creates a new instance.
5685 : !\\
5686 : !\\
5687 : ! !INTERFACE:
5688 : !
5689 0 : SUBROUTINE InstRemove ( Instance )
5690 : !
5691 : ! !INPUT PARAMETERS:
5692 : !
5693 : INTEGER :: Instance
5694 : !
5695 : ! !REVISION HISTORY:
5696 : ! 18 Feb 2016 - C. Keller - Initial version
5697 : ! See https://github.com/geoschem/hemco for complete history
5698 : !EOP
5699 : !------------------------------------------------------------------------------
5700 : !BOC
5701 : INTEGER :: RC
5702 : TYPE(MyInst), POINTER :: PrevInst
5703 : TYPE(MyInst), POINTER :: Inst
5704 :
5705 : !=================================================================
5706 : ! InstRemove begins here!
5707 : !=================================================================
5708 :
5709 : ! Get instance. Also archive previous instance.
5710 0 : PrevInst => NULL()
5711 0 : Inst => NULL()
5712 0 : CALL InstGet ( Instance, Inst, RC, PrevInst=PrevInst )
5713 :
5714 : ! Instance-specific deallocation
5715 0 : IF ( ASSOCIATED(Inst) ) THEN
5716 :
5717 : !--------------------------------------------------------------
5718 : ! Deallocate fields of Inst before popping off from the list
5719 : ! in order to avoid memory leaks (Bob Yantosca (17 Aug 2022)
5720 : !--------------------------------------------------------------
5721 0 : IF ( ASSOCIATED( Inst%ERD_FCT_GEO ) ) THEN
5722 0 : DEALLOCATE(Inst%ERD_FCT_GEO )
5723 : ENDIF
5724 0 : Inst%ERD_FCT_GEO => NULL()
5725 :
5726 0 : IF ( ASSOCIATED( Inst%SRCE_FUNC ) ) THEN
5727 0 : DEALLOCATE(Inst%SRCE_FUNC )
5728 : ENDIF
5729 0 : Inst%SRCE_FUNC => NULL()
5730 :
5731 0 : IF ( ASSOCIATED( Inst%LND_FRC_DRY ) ) THEN
5732 0 : DEALLOCATE(Inst%LND_FRC_DRY )
5733 : ENDIF
5734 0 : Inst%LND_FRC_DRY => NULL()
5735 :
5736 0 : IF ( ASSOCIATED( Inst%MSS_FRC_CACO3 ) ) THEN
5737 0 : DEALLOCATE(Inst%MSS_FRC_CACO3)
5738 : ENDIF
5739 0 : Inst%MSS_FRC_CACO3 => NULL()
5740 :
5741 0 : IF ( ASSOCIATED( Inst%MSS_FRC_CLY ) ) THEN
5742 0 : DEALLOCATE(Inst%MSS_FRC_CLY)
5743 : ENDIF
5744 0 : Inst%MSS_FRC_CLY => NULL()
5745 :
5746 0 : IF ( ASSOCIATED( Inst%MSS_FRC_SND ) ) THEN
5747 0 : DEALLOCATE(Inst%MSS_FRC_SND )
5748 : ENDIF
5749 0 : Inst%MSS_FRC_SND => NULL()
5750 :
5751 0 : IF ( ASSOCIATED( Inst%SFC_TYP ) ) THEN
5752 0 : DEALLOCATE(Inst%SFC_TYP )
5753 : ENDIF
5754 0 : Inst%SFC_TYP => NULL()
5755 :
5756 0 : IF ( ASSOCIATED( Inst%VAI_DST ) ) THEN
5757 0 : DEALLOCATE(Inst%VAI_DST )
5758 : ENDIF
5759 0 : Inst%VAI_DST => NULL()
5760 :
5761 0 : IF ( ALLOCATED( Inst%PLN_TYP ) ) THEN
5762 0 : DEALLOCATE( Inst%PLN_TYP )
5763 : ENDIF
5764 :
5765 0 : IF ( ALLOCATED( Inst%PLN_FRC ) ) THEN
5766 0 : DEALLOCATE( Inst%PLN_FRC )
5767 : ENDIF
5768 :
5769 0 : IF ( ALLOCATED( Inst%TAI ) ) THEN
5770 0 : DEALLOCATE( Inst%TAI )
5771 : ENDIF
5772 :
5773 0 : IF ( ALLOCATED( Inst%DMT_VWR ) ) THEN
5774 0 : DEALLOCATE( Inst%DMT_VWR )
5775 : ENDIF
5776 :
5777 0 : IF ( ALLOCATED( Inst%OVR_SRC_SNK_FRC ) ) THEN
5778 0 : DEALLOCATE( Inst%OVR_SRC_SNK_FRC )
5779 : ENDIF
5780 :
5781 0 : IF ( ALLOCATED( Inst%OVR_SRC_SNK_MSS ) ) THEN
5782 0 : DEALLOCATE( Inst%OVR_SRC_SNK_MSS )
5783 : ENDIF
5784 :
5785 0 : IF ( ALLOCATED( Inst%DMT_MIN ) ) THEN
5786 0 : DEALLOCATE( Inst%DMT_MIN )
5787 : ENDIF
5788 :
5789 0 : IF ( ALLOCATED( Inst%DMT_MAX ) ) THEN
5790 0 : DEALLOCATE( Inst%DMT_MAX )
5791 : ENDIF
5792 :
5793 0 : IF ( ALLOCATED( Inst%DMT_VMA_SRC ) ) THEN
5794 0 : DEALLOCATE( Inst%DMT_VMA_SRC )
5795 : ENDIF
5796 :
5797 0 : IF ( ALLOCATED( Inst%GSD_ANL_SRC ) ) THEN
5798 0 : DEALLOCATE( Inst%GSD_ANL_SRC )
5799 : ENDIF
5800 :
5801 0 : IF ( ALLOCATED( Inst%MSS_FRC_SRC ) ) THEN
5802 0 : DEALLOCATE( Inst%MSS_FRC_SRC )
5803 : ENDIF
5804 :
5805 0 : IF ( ALLOCATED( Inst%HcoIDs ) ) THEN
5806 0 : DEALLOCATE( Inst%HcoIDs )
5807 : ENDIF
5808 :
5809 0 : IF ( ALLOCATED( Inst%HcoIDsALK ) ) THEN
5810 0 : DEALLOCATE( Inst%HcoIDsALK )
5811 : ENDIF
5812 :
5813 : !--------------------------------------------------------------
5814 : ! Pop off instance from list
5815 : !--------------------------------------------------------------
5816 0 : IF ( ASSOCIATED(PrevInst) ) THEN
5817 0 : PrevInst%NextInst => Inst%NextInst
5818 : ELSE
5819 0 : AllInst => Inst%NextInst
5820 : ENDIF
5821 0 : DEALLOCATE(Inst)
5822 :
5823 : ENDIF
5824 :
5825 : ! Free pointers before exiting
5826 0 : PrevInst => NULL()
5827 0 : Inst => NULL()
5828 :
5829 0 : END SUBROUTINE InstRemove
5830 : !EOC
5831 : #if defined ( MODEL_GEOS )
5832 : !------------------------------------------------------------------------------
5833 : SUBROUTINE ReadTuningFactor(HcoState, TuningTable, FCT, RC )
5834 : !
5835 : USE HCO_CharTools_Mod
5836 : USE HCO_inquireMod, ONLY : findFreeLUN
5837 :
5838 : ! Arguments
5839 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
5840 : CHARACTER(LEN=*), INTENT(IN) :: TuningTable
5841 : REAL*8 , INTENT(INOUT) :: FCT
5842 : INTEGER , INTENT(INOUT) :: RC
5843 :
5844 : ! Return value
5845 :
5846 : ! Local variables
5847 : REAL(hp) :: AM2, RES
5848 : INTEGER :: IU, IDX
5849 : CHARACTER(LEN=7) :: CSLABEL, FNDLABEL
5850 : CHARACTER(LEN=255) :: MSG, LINE, ICSL
5851 : LOGICAL :: EX, EOF
5852 :
5853 : CHARACTER(LEN=255), PARAMETER :: LOC =
5854 : & 'ReadTuningFactor (hcox_dustdead_mod)'
5855 :
5856 : !================================================================
5857 : ! ReadTuningFactor begins here!
5858 : !================================================================
5859 :
5860 : ! Enter
5861 : CALL HCO_ENTER ( HcoState%Config%Err, LOC, RC )
5862 :
5863 : ! Init
5864 : FCT = -999.0
5865 :
5866 : ! Determine resolution based on grid cell area
5867 : CSLABEL = 'UNKNOWN'
5868 : FNDLABEL = TRIM(CSLABEL)
5869 : IF ( .NOT. HcoState%Grid%AREA_M2%Alloc ) THEN
5870 : MSG = 'Warning: AREA_M2 not found, will use default number'
5871 : CALL HCO_WARNING( MSG, RC, .TRUE., LOC )
5872 : ELSE
5873 : AM2 = SUM(HcoState%Grid%AREA_M2%Val)/(HcoState%NX*HcoState%NY)
5874 : RES = SQRT(AM2)
5875 : IF ( RES > 280.0_hp ) THEN
5876 : CSLABEL = 'C24'
5877 : ELSEIF ( RES > 140.0_hp .AND. RES <= 280.0_hp ) THEN
5878 : CSLABEL = 'C48'
5879 : ELSEIF ( RES > 70.0_hp .AND. RES <= 140.0_hp ) THEN
5880 : CSLABEL = 'C90'
5881 : ELSEIF ( RES > 35.0_hp .AND. RES <= 70.0_hp ) THEN
5882 : CSLABEL = 'C180'
5883 : ELSEIF ( RES > 17.5_hp .AND. RES <= 35.0_hp ) THEN
5884 : CSLABEL = 'C360'
5885 : ELSEIF ( RES > 8.75_hp .AND. RES <= 17.5_hp ) THEN
5886 : CSLABEL = 'C720'
5887 : ELSEIF ( RES > 4.375_hp .AND. RES <= 8.75_hp ) THEN
5888 : CSLABEL = 'C1440'
5889 : ELSEIF ( RES <= 4.375_hp ) THEN
5890 : CSLABEL = 'C2880'
5891 : ENDIF
5892 : ENDIF
5893 :
5894 : ! Open file
5895 : INQUIRE( FILE=TRIM(TuningTable), EXIST=EX )
5896 : IF ( .NOT. EX ) THEN
5897 : MSG = 'FILE NOT FOUND: '//TRIM(TuningTable)
5898 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
5899 : RETURN
5900 : ENDIF
5901 : IU = findFreeLUN()
5902 : OPEN( IU, FILE=TRIM(TuningTable) )
5903 :
5904 : ! Search for resolution entry in file, assuming they are listed as follows:
5905 : ! C360: 1.0
5906 : ! C48: 2.0e2
5907 : ! C90: 1.0e-4
5908 : DO
5909 : CALL HCO_ReadLine ( IU, LINE, EOF, RC )
5910 : IF ( EOF ) EXIT
5911 : IDX = INDEX( LINE, ':' )
5912 : IF ( IDX > 0 ) ICSL = ADJUSTL(LINE(1:(IDX-1)))
5913 : ! If cube-sphere label matches current resolution, read factor
5914 : IF ( TRIM(ICSL)==TRIM(CSLABEL) ) THEN
5915 : READ(LINE(IDX+1:LEN(LINE)),*) FCT
5916 : FNDLABEL = TRIM(ICSL)
5917 : EXIT
5918 : ENDIF
5919 : ENDDO
5920 :
5921 : ! All done
5922 : CLOSE ( IU )
5923 :
5924 : ! Verbose
5925 : IF ( HcoState%amIRoot ) THEN
5926 : MSG = 'Read dust tuning factor from '//TRIM(TuningTable)
5927 : CALL HCO_MSG(HcoState%Config%Err,MSG, SEP1='-' )
5928 : MSG = 'Model resolution: '//TRIM(CSLABEL)
5929 : CALL HCO_MSG(HcoState%Config%Err,MSG, SEP1='-' )
5930 : MSG = 'Resolution label in file: '//TRIM(FNDLABEL)
5931 : CALL HCO_MSG(HcoState%Config%Err,MSG, SEP1='-' )
5932 : WRITE(MSG,*) 'Scale factor: ',FCT
5933 : CALL HCO_MSG(HcoState%Config%Err,MSG, SEP1='-' )
5934 : ENDIF
5935 :
5936 : ! Leave
5937 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
5938 :
5939 : END SUBROUTINE ReadTuningFactor
5940 : #endif
5941 0 : END MODULE HCOX_DUSTDEAD_MOD
5942 : !EOM
|
