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