LCOV - code coverage report
Current view: | top level - hemco/HEMCO/src/Extensions - hcox_dustdead_mod.F (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 0 | 950 | 0.0 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 0 | 38 | 0.0 %

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

Generated by: LCOV version 1.14