diff --git a/model/ATM_DRV.f b/model/ATM_DRV.f index f30020d..46bb773 100644 --- a/model/ATM_DRV.f +++ b/model/ATM_DRV.f @@ -1016,14 +1016,6 @@ subroutine new_io_atmvars(fid,iorw) #ifdef CALCULATE_FLAMMABILITY call new_io_flammability(fid,iorw) #endif -#ifdef TRACERS_ON - select case (iorw) - case (ioread) - call tracerIO(fid, 'read_dist') - case (iowrite) - call tracerIO(fid, 'write_dist') - end select -#endif #ifdef TRACERS_GC select case (iorw) case (ioread) @@ -1031,16 +1023,14 @@ subroutine new_io_atmvars(fid,iorw) case (iowrite) call IO_CHEM(fid, 'write_dist') end select -#endif -#ifdef TRACERS_GC +#elif TRACERS_ON select case (iorw) case (ioread) - call IO_CHEM(fid, 'read_dist') + call tracerIO(fid, 'read_dist') case (iowrite) - call IO_CHEM(fid, 'write_dist') + call tracerIO(fid, 'write_dist') end select #endif - call new_io_subdd (fid,iorw) call new_io_fluxes (fid,iorw) return diff --git a/model/CLOUDS2_DRV.F90 b/model/CLOUDS2_DRV.F90 index 754edde..d73f4c1 100644 --- a/model/CLOUDS2_DRV.F90 +++ b/model/CLOUDS2_DRV.F90 @@ -635,6 +635,7 @@ subroutine CONDSE numThreads = 1 ! no openmp +#if (defined CALCULATE_LIGHTNING) || (defined TRACERS_SPECIAL_Shindell) #ifdef AUTOTUNE_LIGHTNING IF ( SUM(CNT_FR) .gt. 0 ) THEN TUNE_LT_LAND = LAND_FR_LIS*SUM(CNT_FR)/SUM(LAND_FR_UNC) @@ -651,10 +652,11 @@ subroutine CONDSE 'CLOUDS2_DRV: Calculating land/sea tuning parameters:', & TUNE_LT_LAND, TUNE_LT_SEA !CALL STOP_MODEL( 'LTM Testing',17) - FLASH_DENS = 0d0 - !CG_DENS = 0d0 FLASH_UNC = 0d0 #endif + FLASH_DENS = 0d0 + ! CG_DENS = 0d0 ! TODO: Should this variable be dropped? +#endif !**** !**** MAIN J LOOP diff --git a/model/RAD2_COM.F90 b/model/RAD2_COM.F90 deleted file mode 100644 index 712f775..0000000 --- a/model/RAD2_COM.F90 +++ /dev/null @@ -1,882 +0,0 @@ -#include "rundeck_opts.h" - -#ifdef SKIP_TRACERS_RAD -#undef TRACERS_ON -#endif - MODULE RAD_COM -!@sum RAD_COM Model radiation arrays and parameters -!@auth Original Development Team - USE RESOLUTION, ONLY : IM, JM, LM - USE ATM_COM, ONLY : LM_REQ - USE RADPAR, ONLY : S0, NRAERO_AOD => NTRACE - USE ABSTRACTORBIT_MOD, ONLY : ABSTRACTORBIT -#ifdef TRACERS_AMP - USE AERO_CONFIG, ONLY : NMODES -#endif -#ifdef TRACERS_TOMAS - USE TOMAS_AEROSOL, ONLY : ICOMP -#endif -#if (defined TRACERS_DUST) || (defined TRACERS_MINERALS) - USE TRDUST_MOD, ONLY : NSUBCLAYS - USE TRACER_COM, ONLY : NTM_DUST, NTM_CLAY, NTM_SIL1, NTM_SIL2, & - NTM_SIL3, NTM_SIL4, NTM_SIL5 -#endif -!@var S0 solar 'constant' needs to be saved between calls to radiation - IMPLICIT NONE - SAVE - -!@dbparam NRad : DT_Rad = NRad*DTsrc -#ifdef GCAP - INTEGER :: NRad = 1 -#else - INTEGER :: NRad = 5 -#endif -!@var MODRD : if MODRD=0 do radiation, else skip - INTEGER :: MODRD - -!**** DEFAULT ORBITAL PARAMETERS FOR EARTH -!**** Note PMIP runs had specified values that do not necesarily -!**** coincide with those used as the default, or the output of ORBPAR. -!**** OMEGT OBLIQ ECCEN -!**** DEFAULT (2000 AD) : 282.9 23.44 0.0167 -!**** PMIP CONTROL : 282.04 23.446 0.016724 -!**** PMIP 6kyr BP : 180.87 24.105 0.018682 -!**** PMIP LGM (21k) : 294.42 22.949 0.018994 -!@param OMEGT_def precession angle (degrees from vernal equinox) - REAL*8, PARAMETER :: OMEGT_DEF = 282.9D0 -!@param OBLIQ_def obliquity angle (degrees) - REAL*8, PARAMETER :: OBLIQ_DEF = 23.44D0 -!@param ECCN_def eccentricity - REAL*8, PARAMETER :: ECCN_DEF = .0167D0 -!@var OMEGT,OBLIQ,ECCN actual orbital parameters used - REAL*8 OMEGT, OBLIQ, ECCN - -!**** Database parameters to control orbital parameter calculation -!**** Note : setting variable_orb_par=0, orb_par_year_bp=-50 (=year 2000) -!**** does not produce exactly the same as the default values. -!@dbparam variable_orb_par 1 if orbital parameters are time dependent -!@+ 1 : use orb par from year "JYEAR - orb_par_year_bp" -!@+ 0 : use orb par from year orb_par_year_bp (BP=before 1950) -!@+ -1 : set eccn/obliq/omegt to orb_par(1 : 3) -!@+ else : set eccn/obliq/omegt to defaults of orb_par - INTEGER :: variable_orb_par = -2 -!@dbparam orb_par_year_bp = offset from model_year or 1950 (fixed case) - INTEGER :: orb_par_year_bp = 0 -!@dbparam orb_par :: directly specifies orbital parameters - REAL*8, DIMENSION(3) :: orb_par = (/ECCN_DEF,OBLIQ_DEF, & - OMEGT_DEF/) - -!@var dimrad_sv dimension sum of input fields saved for radia_only runs - INTEGER, PARAMETER :: DIMRAD_SV = IM*JM*(7*LM+3*LM_REQ+24) -!@var RQT Radiative equilibrium temperatures above model top - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: RQT -!@var Tchg Total temperature change in adjusted forcing runs - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: Tchg -!@var SRHR(0) Solar raditive net flux into the ground (W/m^2) -!@var TRHR(0) Thermal raditive downward flux into ground(W/O -StB*T^4)(W/m^2) -!@* Note : -StB*T^4 is added in SURFACE, since T varies betw. rad. calls -!@var SRHR(1->LM) Solar raditive heating rate (W/m^2) (short wave) -!@var TRHR(1->LM) Thermal raditive heating rate (W/m^2) (long wave) - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: SRHR, TRHR -!@var TRSURF upward thermal radiation at the surface from rad step W/m2 - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: TRSURF -!@var FSF Solar Forcing over each type (W/m^2) - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: FSF -!@var FSRDIR Solar incident at surface, direct fraction (1) -!@var DIRVIS Direct beam solar incident at surface (W/m^2) - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: FSRDIR, DIRVIS -!@var SRVISSURF Incident solar direct+diffuse visible at surface (W/m^2) - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: SRVISSURF -!@var SRDN Total incident solar at surface (W/m^2) - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: SRDN - ! saved in rsf -!@var FSRDIF diffuse visible incident solar at surface - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: FSRDIF -!@var DIRNIR direct nir incident solar at surface - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: DIRNIR -!@var DIFNIR diffuse nir incident solar at surface - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: DIFNIR -!@var srnflb_save Net solar radiation (W/m^2) -!@var trnflb_save Net thermal radiation (W/m^2) - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: srnflb_save, & - trnflb_save -#ifdef GCAP -!@var save_alb Surface albedo (unitless) - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: save_alb -!@var TAUW3D,TAUI3D water,ice cloud opt. depths (for diags) - REAL*8, DIMENSION( : , : , : ), ALLOCATABLE :: TAUW3D, TAUI3D -#endif -!@var TAUSUMW,TAUSUMI column-sum water,ice cloud opt. depths (for diags) - REAL*8, DIMENSION(:,:), ALLOCATABLE :: TAUSUMW, TAUSUMI -#ifdef mjo_subdd -!@var OLR_acc, OLR_cnt -- Net thermal radiation at TOA (W/m^2) for SUBDD - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: OLR_acc - REAL*8 :: OLR_cnt = 0.D0 -!@var SWHR,LWHR,SWHR_cnt,LWHR_cnt -- shortwave/longwave heating rates for SUBDD (C/d) - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: SWHR, LWHR - REAL*8 :: SWHR_cnt = 0.D0 - REAL*8 :: LWHR_cnt = 0.D0 -!@var swu_avg,swu_cnt -- upward shortwave fluxes at srf for SUBDD (C/d) - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: swu_avg - REAL*8 :: swu_cnt = 0.D0 -#endif -#ifdef TRACERS_ON - -!@var DIAG_FC Controls the number of radiation calls for the calculation of -!@+ aerosol radiative forcing. One call if =1, multiple calls if -!@+ =2, with their number depending on the aerosol scheme used. -!@+ Use =2 sparingly, it is s l o w. Default is 1. No calls if zero. - INTEGER :: diag_fc = 1 -! nraero_xxxx are the aerosol-specific nraero_aod (old ntrace) components of -! aerosol-active species in radiation. nraero_aod=sum(nraero_xxxx) -!@var nraero_aod Number of aerosol types in optical depth calculations -!@var nraero_rf Number of aerosol types in forcing calculations, which is -!@+ different from nraero_aod when DIAG_FC=1 (default) - INTEGER :: nraero_rf = 0 -#ifdef TRACERS_AEROSOLS_Koch -#ifdef SULF_ONLY_AEROSOLS - INTEGER, PARAMETER :: NRAERO_KOCH = 1 -#else -#ifdef TRACERS_AEROSOLS_VBS -#ifdef TRACERS_AEROSOLS_SOA - INTEGER, PARAMETER :: NRAERO_KOCH = 5 -#else - INTEGER, PARAMETER :: NRAERO_KOCH = 4 -#endif /* TRACERS_AEROSOLS_SOA */ -#else -#ifdef TRACERS_AEROSOLS_SOA - INTEGER, PARAMETER :: NRAERO_KOCH = 6 -#else - INTEGER, PARAMETER :: NRAERO_KOCH = 5 -#endif /* TRACERS_AEROSOLS_SOA */ -#endif /* TRACERS_AEROSOLS_VBS */ -#endif /* SULF_ONLY_AEROSOLS */ -#else - INTEGER, PARAMETER :: NRAERO_KOCH = 0 -#endif /* TRACERS_AEROSOLS_Koch */ - -#ifdef TRACERS_NITRATE - INTEGER, PARAMETER :: NRAERO_NITRATE = 1 -#else - INTEGER, PARAMETER :: NRAERO_NITRATE = 0 -#endif /* TRACERS_NITRATE */ - -#if (defined TRACERS_DUST) || (defined TRACERS_MINERALS) - INTEGER, PARAMETER :: NRAERO_CLAY = NSUBCLAYS*NTM_CLAY - INTEGER, PARAMETER :: NRAERO_DUST = NRAERO_CLAY + NTM_SIL1 + & - NTM_SIL2 + NTM_SIL3 + NTM_SIL4 + NTM_SIL5 -!@var nr_soildust First index of dust tracers in radiation (nraero_aod) - INTEGER :: nr_soildust = 0 -#else - INTEGER, PARAMETER :: NRAERO_CLAY = 0 - INTEGER, PARAMETER :: NRAERO_DUST = 0 -#endif /* TRACERS_DUST */ - -!@var nraero_OMA Number of OMA tracers that have an AOD value -!@var nraero_AMP Number of AMP tracers that have an AOD value -!@var nraero_TOMAS Number of TOMAS tracers that have an AOD value - INTEGER :: nraero_OMA = 0 - INTEGER :: nraero_AMP = 0 - INTEGER :: nraero_TOMAS = 0 - -#ifdef TRACERS_AEROSOLS_SEASALT - INTEGER, PARAMETER :: NRAERO_SEASALT = 2 -#else - INTEGER, PARAMETER :: NRAERO_SEASALT = 0 -#endif /* TRACERS_AEROSOLS_SEASALT */ - -#ifdef TRACERS_ON -!@var njaero max expected rad code tracers passed to photolysis -!@var nraero_aod_rsf value of nraero_aod found in the rsf file -!@var nraero_rf_rsf value of nraero_rf found in the rsf file -!@var save_dry_aod_rsf value of save_dry_aod found in the rsf file -!@var tau_as All-sky aerosol optical saved 1 : nraero_aod not 1 : ntm -!@+ This is so clays are separate. Now also used for old parameter -!@+ mxfastj : Number of aerosol/cloud types currently active in the model -!@var tau_cs Same as tau_as for clear-sky -!@var tau_dry Same as tau_as for dry aerosol (RH=0%) - INTEGER :: njaero - ! nraero_aod+2 cloud types (water/ice) - INTEGER :: nraero_aod_rsf = 0 - INTEGER :: nraero_rf_rsf = 0 - INTEGER :: save_dry_aod_rsf = 0 - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: tau_as - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: tau_cs - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: tau_dry -#ifdef CACHED_SUBDD -!@var abstau_as Same as tau_as for absorption -!@var abstau_cs Same as tau_cs for absorption -!@var abstau_dry Same as tau_dry for absorption -!@var swfrc Shortwave aerosol radiative forcing -!@var lwfrc Shortwave aerosol radiative forcing - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: abstau_as - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: abstau_cs - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: abstau_dry - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: swfrc, lwfrc -#endif /* CACHED_SUBDD */ -#endif -#endif -!@var CFRAC Total cloud fraction as seen be radiation - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: CFRAC - ! saved in rsf -!@var RCLD Total cloud optical depth as seen be radiation - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: RCLD - ! saved in rsf -!@var chem_tracer_save 3D O3, CH4 saved elsewhere for use in radiation - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: chem_tracer_save - !saved rsf -#ifdef GCC_COUPLE_RAD -!@var GCCco2_tracer_save 3D CO2 saved elsewhere for use in radiation - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: GCCco2_tracer_save - !saved rsf -#endif -#if (defined SHINDELL_STRAT_EXTRA) && (defined ACCMIP_LIKE_DIAGS) -!@var stratO3_tracer_save 3D stratOx saved elsewhere for use in rad code - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: stratO3_tracer_save - !saved rsf -#endif -!@var rad_to_chem save 3D quantities from radiation code for use in -!@+ chemistry (or rest of model). 1=Ozone, 2=aerosol ext, 3=N2O, 4=CH4, -!@+ 5=CFC11+CFC12 - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: rad_to_chem - !saved in rsf - REAL*8, ALLOCATABLE, DIMENSION( : , : , : , : ) :: rad_to_file -#ifdef GCC_COUPLE_RAD -!@var GCCco2rad_to_chem save 3D quantities from radiation code - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: GCCco2rad_to_chem - !saved in rsf - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: GCCco2rad_to_file -#endif -!@var KLIQ Flag indicating dry(0)/wet(1) atmosphere (memory feature) - INTEGER, ALLOCATABLE, DIMENSION( : , : , : , : ) :: KLIQ - ! saved in rsf -!@dbparam Ikliq 0,1,-1 initialize kliq as dry,equil,current model state - INTEGER :: Ikliq = -1 - ! get kliq-array from restart file -!@dbparam RHfix const.rel.humidity passed to radiation for aeros. tests - REAL*8 :: RHfix = -1. - ! pass the current model rel.humidity -!@dbparam dalbsnX global coeff for snow alb change by black carbon depos - REAL*8 :: dalbsnX = 0. -!@dbparam albsn_yr year of blk carb depos used for snow alb. reduction - INTEGER :: albsn_yr = 1951 - -! variables related to aerosol indirect effects : -! (CDNC=cloud droplet number concentration) -!@dbparam CC_CDNCx scaling factor relating cld cvr change and CDNC change - REAL*8 :: CC_CDNCX = .0000D0 - ! .0036d0 -!@dbparam OC_CDNCx scaling factor relating cld opt depth and CDNC change - REAL*8 :: OD_CDNCX = .0000D0 - ! .007d0 -!@var pcdnc,vcdnc pressure,vertical profile for cld.cvr change - REAL*8, PARAMETER, DIMENSION(7) & - :: PCDNC = (/984.D0,964.D0,934.D0, & - 884.D0,810.D0,710.D0,550.D0/), & - VCDNC = (/.35D0,.20D0,.10D0,.17D0, & - .10D0,.08D0,0.D0/) -!@var cdncl = vcdnc interpolated to current vertical resolution - REAL*8 cdncl(LM) - -!@var COSZ1 Mean Solar Zenith angle for curr. physics(not rad) time step - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: COSZ1 - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: save_COSZ2 - REAL*8, ALLOCATABLE, DIMENSION(:,:,:,:) :: save_RF - REAL*8, ALLOCATABLE, DIMENSION(:,:,:,:) :: save_RF_TP - REAL*8, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: save_RF_3D -!@var COSZ_day Mean Solar Zenith angle for current day - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: COSZ_day -!@var SUNSET Time of sunset for current day (radians from local noon) - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: SUNSET -!@dbparam S0X solar constant multiplication factor - REAL*8 :: S0X = 1. -!@dbparam S0_yr,S0_day obs.date of solar constant (if 0 : time var) - INTEGER :: S0_yr = 1951, S0_day = 182 -!@dbparam CO2X,... scaling factors for CO2 N2O CH4 CFC11 CFC12 XGHG - REAL*8 :: CO2X = 1., N2OX = 1., CH4X = 1., CFC11X = 1., & - CFC12X = 1., XGHGX = 1., O2X = 1., NO2X = 1., & - N2CX = 1., YGHGX = 2., SO2X = 0., & - CH4X_RADoverCHEM = 1.D0 -!@dbparm ref_mult factor to control REFDRY from rundeck - REAL*8 :: ref_mult = 1. -!@dbparam GHG_yr,GHG_day obs.date of well-mixed GHgases (if 0 : time var) - INTEGER :: GHG_yr = 1951, GHG_day = 182 -!@dbparam Volc_yr,Volc_day obs.date of Volc.Aerosols (if 0 : time var) -!@+ special cases : Volc_yr=-1 : 150-yr mean 1850-1999 -!@+ Volc_yr=-2010 : current year up to 2010 then -!@+ repeat volcanos from 100 yrs ago -!@+ Volc_yr=-2000 : older way of creating future volc - INTEGER :: Volc_yr = 1951, Volc_day = 182 -!@dbparam Aero_yr obs.year of troposph.Aerosols (if 0 : use current yr) - INTEGER :: Aero_yr = 1951 ! always use annual cycle -!@dbparam dust_yr nominal year for prescribed dust climatology (if 0 : use current yr) - INTEGER :: dust_yr = 1951 ! always use annual cycle -!@dbparam O3_yr obs.year of Ozone (if 0 : use current year) - INTEGER :: O3_yr = 1951 ! always use annual cycle -!@dbparam H2OstratX strat_water_vapor, cloud, Ozone scaling factor - REAL*8 :: H2OstratX = 1., cldX = 1., O3X = 1. -!@dbparam H2ObyCH4 if not 0 : add CH4 produced H2O into layers 1->LM - REAL*8 :: H2ObyCH4 = 1. -!@var dH2O zonal H2O-prod.rate in kg/m^2/ppm_CH4/second in layer L - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: dH2O -!@var RSDIST,SIND,COSD orbit related variables computed once a day - REAL*8 :: RSDIST, SIND, COSD -!@var ALB is SRNFLB(1)/(SRDFLB(1)+1.D-20),PLAVIS,PLANIR,ALBVIS,ALBNIR, -!@+ SRRVIS,SRRNIR,SRAVIS,SRANIR (see RADIATION) - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ), TARGET :: ALB - -!@var SALB (1.-broadband surface albedo) - saved in rsf - REAL*8, POINTER, DIMENSION(:,:) :: SALB ! = ALB( : , : ,1) -! EQUIVALENCE (SALB,ALB) - -#ifdef ALTER_RADF_BY_LAT -!@var FULGAS_lat multiplicative factors for altering FULGAS by latitude -!@+ for non-transient runs. (greenhouse gas regional forcing) - REAL*8, DIMENSION(13,46) :: FULGAS_lat - !rad not model grid, 13 gasses -!@var FS8OPX_lat multiplicative factors for altering FS8OPX by latitude -!@+ for non-transient runs. (aerosol regional forcing) SOLAR -!@var FT8OPX_lat multiplicative factors for altering FT8OPX by latitude -!@+ for non-transient runs. (aerosol regional forcing) THERMAL - REAL*8, DIMENSION(8,46) :: FS8OPX_lat, FT8OPX_lat - !rad not model grid - !8 groups of aerosols -#endif -!@dbparam rad_interact_aer =1 for radiatively active non-chem tracers - INTEGER :: rad_interact_aer = 0 - ! defaults to 0 -!@dbparam clim_interact_chem=1 for radiatively active chem tracers -!@+ also affects chemisty to humidity feedback - INTEGER :: clim_interact_chem = 0 - ! defaults to 0 - -!@dbparam nradfrc sets frequency of inst. rad. forcing calculations - INTEGER :: nradfrc = 1 - ! do them every nrad*nradfrc physics steps -! nradfrc=0 : skip all, no repeated radiation calculations -!**** the radiative forcing level for instantaneous forcing calcs is set -!**** using the rad_forc_lev parameter. -!@dbparam rad_forc_lev = 0 for TOA, 1 for LTROPO (default=0) - INTEGER :: rad_forc_lev = 0 - -!@dbparam cloud_rad_forc = 1 for calculation of cloud radiative forcing - INTEGER :: cloud_rad_forc = 0 - -!@dbparam TAero_aod_diag = 1 outputs offline aerosol optical properties, -!@+ = 2 outputs band 6 only. Note this only works for background aerosols, -!@+ not tracers. - INTEGER :: TAero_aod_diag = 0 -!@dbparam aer_rad_forc = 1 for calculation of aerosol radiative forcing -!@+ note this only works for background aerosols, not tracers - INTEGER :: aer_rad_forc = 0 - -!@var co2ppm Current CO2 level as seen by radiation - REAL*8 :: co2ppm = 280. ! set a reasonable default value - -!**** Local variables initialised in init_RAD -!@var PLB0,QL0 global parts of local arrays (to avoid OMP-copyin) - REAL*8, DIMENSION(LM_REQ) :: PLB0, SHL0 -!@var ntrix_aod Indexing array for aerosol optical depth tracer names -!@var ntrix_rf Indexing array for aerosol radiative forcing tracer names - INTEGER, ALLOCATABLE, DIMENSION( : ) :: ntrix_aod, ntrix_rf -!@var WTTR weighting array for optional aerosol-ratiation interactions - REAL*8, ALLOCATABLE, DIMENSION( : ) :: WTTR - -#ifdef CUBED_SPHERE -!@var JM_DH2O number of latitudes in CH4->H2O input file -!@var LAT_DH2O latitudes in CH4->H2O input file (converted to radians) - INTEGER, PARAMETER :: JM_DH2O = 18 - REAL*8 :: lat_dh2o(JM_DH2O) -#endif - -!@dbparam snoage_def determines how snowage is calculated : -!@+ = 0 independent of temperature -!@+ = 1 only when max daily local temp. over type > 0 - INTEGER :: snoage_def = 0 - REAL*8, ALLOCATABLE, DIMENSION( : , : , : ) :: SNOAGE - class (AbstractOrbit), allocatable :: orbit - -!@dbparam chl_from_obio =1 to use chl from obio when computing ocean albedo - INTEGER :: chl_from_obio = 0 -!@dbparam chl_from_seawifs =1 to use chl from SeaWIFs when computing ocn albedo - INTEGER :: chl_from_seawifs = 0 - - CONTAINS - - SUBROUTINE RADIATIONSETORBIT(anOrbit) - class (AbstractOrbit), intent(in) :: anOrbit - ALLOCATE( orbit,SOURCE=anOrbit) - END SUBROUTINE RADIATIONSETORBIT - - END MODULE RAD_COM - - SUBROUTINE ALLOC_RAD_COM(grid) -!@sum To allocate arrays who sizes now need to be determined at -!@+ run-time -!@auth Rodger Abel - - USE DOMAIN_DECOMP_ATM, ONLY : DIST_GRID - USE DOMAIN_DECOMP_ATM, ONLY : GETDOMAINBOUNDS - USE RESOLUTION, ONLY : IM, JM, LM - USE ATM_COM, ONLY : LM_REQ -#ifdef TRACERS_ON - USE TRACER_COM, ONLY : NTM -#endif - USE RAD_COM, ONLY : RQT, Tchg, SRHR, TRHR, FSF, FSRDIR, SRVISSURF, & - TRSURF, SRDN, CFRAC, RCLD, chem_tracer_save, rad_to_chem, & - rad_to_file, KLIQ, COSZ1, COSZ_day, SUNSET, dH2O, ALB, SALB, & - SNOAGE, srnflb_save, trnflb_save, FSRDIF, DIRNIR, DIFNIR, & - TAUSUMW, TAUSUMI, DIRVIS -#ifdef GCC_COUPLE_RAD - USE RAD_COM, ONLY : GCCco2_tracer_save, GCCco2rad_to_chem, & - GCCco2rad_to_file -#endif -#ifdef GCAP - USE RAD_COM, ONLY : save_alb, tauw3d, taui3d, save_cosz2, save_rf, save_rf_TP, save_rf_3D -#endif -#ifdef mjo_subdd - USE RAD_COM, ONLY : SWHR_cnt, LWHR_cnt, SWHR, LWHR, OLR_acc, & - OLR_cnt, swu_avg, swu_cnt -#endif -#ifdef CUBED_SPHERE - USE RAD_COM, ONLY : JM_DH2O -#endif -#if (defined SHINDELL_STRAT_EXTRA) & (defined ACCMIP_LIKE_DIAGS) - USE RAD_COM, ONLY : stratO3_tracer_save -#endif - IMPLICIT NONE - TYPE (DIST_GRID), INTENT(IN) :: grid - - INTEGER :: I_0H, I_1H, J_0H, J_1H - INTEGER :: IER - - CALL GETDOMAINBOUNDS(grid,J_STRT_HALO=J_0H,J_STOP_HALO=J_1H) - I_0H = grid%I_STRT_HALO - I_1H = grid%I_STOP_HALO - - ALLOCATE( RQT(LM_REQ,I_0H:I_1H,J_0H:J_1H), & - Tchg(LM+LM_REQ,I_0H:I_1H,J_0H:J_1H), & - SRHR(0 : LM,I_0H:I_1H,J_0H:J_1H), & - TRHR(0 : LM,I_0H:I_1H,J_0H:J_1H), & - TRSURF(4,I_0H:I_1H,J_0H:J_1H),FSF(4,I_0H:I_1H,J_0H:J_1H)& - ,FSRDIR( I_0H:I_1H, J_0H:J_1H ),DIRVIS( I_0H:I_1H, J_0H:J_1H )& - ,SRVISSURF( I_0H:I_1H, J_0H:J_1H ), & - FSRDIF( I_0H:I_1H, J_0H:J_1H ),DIRNIR( I_0H:I_1H, J_0H:J_1H ),& - DIFNIR( I_0H:I_1H, J_0H:J_1H ),TAUSUMW( I_0H:I_1H, J_0H:J_1H )& - ,TAUSUMI( I_0H:I_1H, J_0H:J_1H ), STAT=IER ) -#ifdef GCAP - ALLOCATE( TAUW3D(I_0H:I_1H,J_0H:J_1H,LM), & - TAUI3D(I_0H:I_1H,J_0H:J_1H,LM), STAT=IER ) -#endif - ALLOCATE( SRDN( I_0H:I_1H, J_0H:J_1H ),CFRAC( I_0H:I_1H, J_0H:J_1H ), & - RCLD(LM,I_0H:I_1H,J_0H:J_1H), STAT=IER ) -#ifdef GCC_COUPLE_RAD - ALLOCATE( GCCco2_tracer_save(LM,I_0H:I_1H,J_0H:J_1H), & - GCCco2rad_to_chem(LM,I_0H:I_1H,J_0H:J_1H), & - GCCco2rad_to_file(LM,I_0H:I_1H,J_0H:J_1H), STAT=IER ) -#endif - ALLOCATE( chem_tracer_save(2,LM,I_0H:I_1H,J_0H:J_1H), & - rad_to_chem(5,LM,I_0H:I_1H,J_0H:J_1H), & - rad_to_file(5,LM,I_0H:I_1H,J_0H:J_1H), & - SNOAGE(3,I_0H:I_1H,J_0H:J_1H), STAT=IER ) -#if (defined SHINDELL_STRAT_EXTRA) & (defined ACCMIP_LIKE_DIAGS) - ALLOCATE( stratO3_tracer_save(LM,I_0H:I_1H,J_0H:J_1H), STAT=IER ) -#endif - ALLOCATE( KLIQ(LM,4,I_0H:I_1H,J_0H:J_1H), & - COSZ1( I_0H:I_1H, J_0H:J_1H ), STAT=IER ) - -#ifdef TRACERS_GC - ALLOCATE( save_COSZ2( I_0H:I_1H, J_0H:J_1H ), STAT=IER ) - ! Instantaneous radiative forcing arrays ! 21 species + clouds, 2 bands (SW/LW) - ! TOA - ALLOCATE( save_RF(I_0H:I_1H,J_0H:J_1H, 21, 2 ), STAT=IER ) - save_RF(:,:,:,:) = 0d0 - ! Tropopause - ALLOCATE( save_RF_TP(I_0H:I_1H,J_0H:J_1H, 21, 2 ), STAT=IER ) - save_RF_TP(:,:,:,:) = 0d0 - ! 3D (add extra index @ 0 for total flux) - ALLOCATE( save_RF_3D(I_0H:I_1H,J_0H:J_1H, 1:LM, 0:21, 2 ), STAT=IER ) - save_RF_3D(:,:,:,:,:) = 0d0 -#endif - - ALLOCATE( COSZ_day( I_0H:I_1H, J_0H:J_1H ), & - SUNSET( I_0H:I_1H, J_0H:J_1H ), STAT=IER ) -#ifdef CUBED_SPHERE - ALLOCATE( dH2O(JM_DH2O,LM,12), STAT=IER ) -#else - ALLOCATE( dH2O(J_0H:J_1H,LM,12), STAT=IER ) -#endif - ALLOCATE( ALB(I_0H:I_1H,J_0H:J_1H,9), & - srnflb_save(I_0H:I_1H,J_0H:J_1H,Lm), & - trnflb_save(I_0H:I_1H,J_0H:J_1H,Lm), STAT=IER ) -#ifdef mjo_subdd - ALLOCATE( OLR_acc( I_0H:I_1H, J_0H:J_1H ), & - SWHR(I_0H:I_1H,J_0H:J_1H,Lm), & - LWHR(I_0H:I_1H,J_0H:J_1H,Lm), & - swu_avg( I_0H:I_1H, J_0H:J_1H ), STAT=IER ) -#endif - -#ifdef GCAP -! Allocate and initialize array for holding surface albedo, which is only -! updated during daytime. - ALLOCATE( save_alb( I_0H:I_1H, J_0H:J_1H ), STAT=IER ) - save_alb = 0. -#endif - -#ifdef mjo_subdd - OLR_acc = 0. - OLR_cnt = 0. - SWHR = 0. - LWHR = 0. - SWHR_cnt = 0. - LWHR_cnt = 0. - swu_avg = 0. - swu_cnt = 0. -#endif - KLIQ = 1 - dH2O = 0. - SALB => ALB( : , : ,1) - SRVISSURF = 0 - FSF = 0 - TRSURF = 0 - END SUBROUTINE ALLOC_RAD_COM - - SUBROUTINE DEF_RSF_RAD(fid) -!@sum def_rsf_rad defines radiation array structure in restart files -!@auth M. Kelley -!@ver beta - USE RAD_COM - USE DOMAIN_DECOMP_ATM, ONLY : grid - USE PARIO, ONLY : DEFVAR -#ifdef TRACERS_ON - USE TRDIAG_COM, ONLY : save_dry_aod -#endif - IMPLICIT NONE - INTEGER fid !@var fid file id - - CALL DEFVAR(grid,fid,s0,'s0') - CALL DEFVAR(grid,fid,rqt,'rqt(lm_req,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,kliq,'kliq(lm,four,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,srhr,'srhr(zero_to_lm,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,trhr,'trhr(zero_to_lm,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,trsurf,'trsurf(nstype,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,fsf,'fsf(nstype,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,fsrdir,'fsrdir(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,srvissurf,'srvissurf(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,srdn,'srdn(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,cfrac,'cfrac(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,salb,'salb(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,fsrdif,'fsrdif(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,dirnir,'dirnir(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,difnir,'difnir(dist_im,dist_jm)') - CALL DEFVAR(grid,fid,rcld,'rcld(lm,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,snoage,'snoage(d3,dist_im,dist_jm)') - -#ifdef TRACERS_ON - IF ( nraero_aod>0 ) THEN - CALL DEFVAR(grid,fid,nraero_aod,'nraero_aod') - CALL DEFVAR(grid,fid,save_dry_aod,'save_dry_aod') - CALL DEFVAR(grid,fid,tau_as, & - 'tau_as(dist_im,dist_jm,lm,nraero_aod)') - CALL DEFVAR(grid,fid,tau_cs, & - 'tau_cs(dist_im,dist_jm,lm,nraero_aod)') - IF ( save_dry_aod>0 ) CALL DEFVAR(grid,fid,tau_dry, & - 'tau_dry(dist_im,dist_jm,lm,nraero_aod)') -#ifdef CACHED_SUBDD - CALL DEFVAR(grid,fid,abstau_as, & - 'abstau_as(dist_im,dist_jm,lm,nraero_aod)') - CALL DEFVAR(grid,fid,abstau_cs, & - 'abstau_cs(dist_im,dist_jm,lm,nraero_aod)') - IF ( save_dry_aod>0 ) CALL DEFVAR(grid,fid,abstau_dry, & - 'abstau_dry(dist_im,dist_jm,lm,nraero_aod)') - CALL DEFVAR(grid,fid,nraero_rf,'nraero_rf') - IF ( nraero_rf>0 ) THEN - CALL DEFVAR(grid,fid,swfrc, & - 'swfrc(dist_im,dist_jm,nraero_rf)') - CALL DEFVAR(grid,fid,lwfrc, & - 'lwfrc(dist_im,dist_jm,nraero_rf)') - ENDIF -#endif /* CACHED_SUBDD */ - ENDIF -#ifdef GCC_COUPLE_RAD - CALL DEFVAR(grid,fid,GCCco2_tracer_save, & - 'GCCco2_tracer_save(lm,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,GCCco2rad_to_chem, & - 'GCCco2rad_to_chem(lm,dist_im,dist_jm)') -#endif - -#if (defined TRACERS_SPECIAL_Shindell) - CALL DEFVAR(grid,fid,chem_tracer_save, & - 'chem_tracer_save(two,lm,dist_im,dist_jm)') - CALL DEFVAR(grid,fid,rad_to_chem, & - 'rad_to_chem(five,lm,dist_im,dist_jm)') -#if (defined SHINDELL_STRAT_EXTRA) & (defined ACCMIP_LIKE_DIAGS) - CALL DEFVAR(grid,fid,strato3_tracer_save, & - 'strato3_tracer_save(lm,dist_im,dist_jm)') -#endif -#endif -#ifdef TRACERS_DUST - CALL DEFVAR(grid,fid,srnflb_save, & - 'srnflb_save(dist_im,dist_jm,lm)') - CALL DEFVAR(grid,fid,trnflb_save, & - 'trnflb_save(dist_im,dist_jm,lm)') -#endif -#endif /* TRACERS_ON */ - END SUBROUTINE DEF_RSF_RAD - - SUBROUTINE NEW_IO_RAD(fid,iaction) -!@sum new_io_rad read/write radiation arrays from/to restart files -!@auth M. Kelley -!@ver beta new_ prefix avoids name clash with the default version - USE MODEL_COM, ONLY : IOREAD, IOWRITE -#ifdef TRACERS_ON - USE TRACER_COM, ONLY : NTM - USE TRDIAG_COM, ONLY : save_dry_aod -#endif - USE RAD_COM - USE DOMAIN_DECOMP_ATM, ONLY : grid, GETDOMAINBOUNDS - USE PARIO, ONLY : WRITE_DIST_DATA, READ_DIST_DATA, WRITE_DATA, & - READ_DATA - IMPLICIT NONE - INTEGER fid !@var fid unit number of read/write - INTEGER iaction !@var iaction flag for reading or writing to file - - INTEGER :: I_0H, I_1H - INTEGER :: J_0H, J_1H - - CALL GETDOMAINBOUNDS(grid,J_STRT_HALO=J_0H,J_STOP_HALO=J_1H) - I_0H = grid%I_STRT_HALO - I_1H = grid%I_STOP_HALO - - SELECT CASE (iaction) - CASE (IOWRITE) ! output to restart file - CALL WRITE_DATA(grid,fid,'s0',s0) - CALL WRITE_DIST_DATA(grid,fid,'rqt',rqt,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'kliq',kliq,JDIM=4) - CALL WRITE_DIST_DATA(grid,fid,'srhr',srhr,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'trhr',trhr,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'trsurf',trsurf,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'fsf',fsf,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'salb',salb) - CALL WRITE_DIST_DATA(grid,fid,'fsrdir',fsrdir) - CALL WRITE_DIST_DATA(grid,fid,'srvissurf',srvissurf) - CALL WRITE_DIST_DATA(grid,fid,'fsrdif',fsrdif) - CALL WRITE_DIST_DATA(grid,fid,'dirnir',dirnir) - CALL WRITE_DIST_DATA(grid,fid,'difnir',difnir) - CALL WRITE_DIST_DATA(grid,fid,'srdn',srdn) - CALL WRITE_DIST_DATA(grid,fid,'cfrac',cfrac) - CALL WRITE_DIST_DATA(grid,fid,'rcld',rcld,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'snoage',snoage,JDIM=3) -#if (defined GCC_COUPLE_RAD) - CALL WRITE_DIST_DATA(grid,fid,'GCCco2_tracer_save', & - GCCco2_tracer_save,JDIM=3) - CALL WRITE_DIST_DATA(grid,fid,'GCCco2rad_to_chem', & - GCCco2rad_to_chem,JDIM=3) -#endif -#if (defined TRACERS_SPECIAL_Shindell) - CALL WRITE_DIST_DATA(grid,fid,'chem_tracer_save', & - chem_tracer_save,JDIM=4) - CALL WRITE_DIST_DATA(grid,fid,'rad_to_chem',rad_to_chem,JDIM=4) -#if (defined SHINDELL_STRAT_EXTRA) & (defined ACCMIP_LIKE_DIAGS) - CALL WRITE_DIST_DATA(grid,fid,'strato3_tracer_save', & - strato3_tracer_save,JDIM=3) -#endif -#endif -#ifdef TRACERS_DUST - CALL WRITE_DIST_DATA(grid,fid,'srnflb_save',srnflb_save) - CALL WRITE_DIST_DATA(grid,fid,'trnflb_save',trnflb_save) -#endif -#ifdef TRACERS_ON - IF ( nraero_aod>0 ) THEN - CALL WRITE_DATA(grid,fid,'nraero_aod',nraero_aod) - CALL WRITE_DATA(grid,fid,'save_dry_aod',save_dry_aod) - CALL WRITE_DIST_DATA(grid,fid,'tau_as',tau_as) - CALL WRITE_DIST_DATA(grid,fid,'tau_cs',tau_cs) - IF ( save_dry_aod>0 ) & - CALL WRITE_DIST_DATA(grid,fid,'tau_dry',tau_dry) -#ifdef CACHED_SUBDD - CALL WRITE_DIST_DATA(grid,fid,'abstau_as',abstau_as) - CALL WRITE_DIST_DATA(grid,fid,'abstau_cs',abstau_cs) - IF ( save_dry_aod>0 ) & - CALL WRITE_DIST_DATA(grid,fid,'abstau_dry',abstau_dry) - CALL WRITE_DATA(grid,fid,'nraero_rf',nraero_rf) - IF ( nraero_rf>0 ) THEN - CALL WRITE_DIST_DATA(grid,fid,'swfrc',swfrc) - CALL WRITE_DIST_DATA(grid,fid,'lwfrc',lwfrc) - ENDIF -#endif /* CACHED_SUBDD */ - ENDIF -#endif /* TRACERS_ON */ - CASE (IOREAD) - CALL READ_DATA(grid,fid,'s0',s0,BCAST_ALL=.TRUE.) - CALL READ_DIST_DATA(grid,fid,'rqt',rqt,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'kliq',kliq,JDIM=4) - CALL READ_DIST_DATA(grid,fid,'srhr',srhr,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'trhr',trhr,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'trsurf',trsurf,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'fsf',fsf,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'salb',salb) - fsrdir = 0. - srvissurf = 0. - CALL READ_DIST_DATA(grid,fid,'fsrdir',fsrdir) - CALL READ_DIST_DATA(grid,fid,'srvissurf',srvissurf) - dirvis = fsrdir*srvissurf - ! reconstruct when restarting. - CALL READ_DIST_DATA(grid,fid,'fsrdif',fsrdif) - CALL READ_DIST_DATA(grid,fid,'dirnir',dirnir) - CALL READ_DIST_DATA(grid,fid,'difnir',difnir) - CALL READ_DIST_DATA(grid,fid,'srdn',srdn) - CALL READ_DIST_DATA(grid,fid,'cfrac',cfrac) - CALL READ_DIST_DATA(grid,fid,'rcld',rcld,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'snoage',snoage,JDIM=3) -#ifdef GCC_COUPLE_RAD - CALL READ_DIST_DATA(grid,fid,'GCCco2_tracer_save', & - GCCco2_tracer_save,JDIM=3) - CALL READ_DIST_DATA(grid,fid,'GCCco2rad_to_chem', & - GCCco2rad_to_chem,JDIM=3) -#endif -#if (defined TRACERS_SPECIAL_Shindell) - CALL READ_DIST_DATA(grid,fid,'chem_tracer_save', & - chem_tracer_save,JDIM=4) - CALL READ_DIST_DATA(grid,fid,'rad_to_chem',rad_to_chem,JDIM=4) -#if (defined SHINDELL_STRAT_EXTRA) & (defined ACCMIP_LIKE_DIAGS) - CALL READ_DIST_DATA(grid,fid,'strato3_tracer_save', & - strato3_tracer_save,JDIM=3) -#endif -#endif -#ifdef TRACERS_DUST - CALL READ_DIST_DATA(grid,fid,'srnflb_save',srnflb_save) - CALL READ_DIST_DATA(grid,fid,'trnflb_save',trnflb_save) -#endif -#ifdef TRACERS_ON - IF ( .NOT.ALLOCATED(tau_as) ) THEN - CALL READ_DATA(grid,fid,'nraero_aod',nraero_aod_rsf, & - BCAST_ALL=.TRUE.) - CALL READ_DATA(grid,fid,'save_dry_aod',save_dry_aod_rsf, & - BCAST_ALL=.TRUE.) - IF ( nraero_aod_rsf/=0 ) THEN - ALLOCATE( tau_as(I_0H:I_1H,J_0H:J_1H,LM,nraero_aod_rsf)) - ALLOCATE( tau_cs(I_0H:I_1H,J_0H:J_1H,LM,nraero_aod_rsf)) - IF ( save_dry_aod_rsf>0 ) & - ALLOCATE( tau_dry(I_0H:I_1H,J_0H:J_1H,LM, & - nraero_aod_rsf)) -#ifdef CACHED_SUBDD - ALLOCATE( abstau_as(I_0H:I_1H,J_0H:J_1H,LM,nraero_aod_rsf& - )) - ALLOCATE( abstau_cs(I_0H:I_1H,J_0H:J_1H,LM,nraero_aod_rsf& - )) - IF ( save_dry_aod_rsf>0 ) & - ALLOCATE( abstau_dry(I_0H:I_1H,J_0H:J_1H,LM, & - nraero_aod_rsf)) - CALL READ_DATA(grid,fid,'nraero_rf',nraero_rf_rsf, & - BCAST_ALL=.TRUE.) - IF ( nraero_rf_rsf>0 ) THEN - ALLOCATE( swfrc(I_0H:I_1H,J_0H:J_1H,nraero_rf_rsf)) - ALLOCATE( lwfrc(I_0H:I_1H,J_0H:J_1H,nraero_rf_rsf)) - ENDIF -#endif /* CACHED_SUBDD */ - ENDIF - ENDIF - IF ( ALLOCATED(tau_as) ) THEN - ! needs to be separate from previous if - CALL READ_DIST_DATA(grid,fid,'tau_as',tau_as) - CALL READ_DIST_DATA(grid,fid,'tau_cs',tau_cs) - IF ( save_dry_aod_rsf>0 ) & - CALL READ_DIST_DATA(grid,fid,'tau_dry',tau_dry) -#ifdef CACHED_SUBDD - CALL READ_DIST_DATA(grid,fid,'abstau_as',abstau_as) - CALL READ_DIST_DATA(grid,fid,'abstau_cs',abstau_cs) - IF ( save_dry_aod_rsf>0 ) & - CALL READ_DIST_DATA(grid,fid,'abstau_dry',abstau_dry) - IF ( nraero_rf_rsf>0 ) THEN - CALL READ_DIST_DATA(grid,fid,'swfrc',swfrc) - CALL READ_DIST_DATA(grid,fid,'lwfrc',lwfrc) - ENDIF -#endif /* CACHED_SUBDD */ - ENDIF -#endif /* TRACERS_ON */ - ENDSELECT - END SUBROUTINE NEW_IO_RAD - - SUBROUTINE READ_RAD_IC -!@sum read_rad_ic read radiation coldstart initial conditions file. - USE RAD_COM, ONLY : snoage - USE DOMAIN_DECOMP_ATM, ONLY : grid - USE PARIO, ONLY : PAR_OPEN, PAR_CLOSE, READ_DIST_DATA - USE FILEMANAGER, ONLY : FILE_EXISTS - IMPLICIT NONE - INTEGER fid !@var fid unit number of read/write - - IF ( FILE_EXISTS('GIC') ) THEN - ! Read snow age using old-style IC (from rsf) - fid = PAR_OPEN(grid,'GIC','read') - CALL READ_DIST_DATA(grid,fid,'snoage',snoage,JDIM=3) - CALL PAR_CLOSE(grid,fid) - ELSE - ! Newer cold-start IC files contain only the fundamental state variables. - ! Set snow age to zero (Initial snow albedo irrelevant for cold starts). - snoage = 0D0 - ENDIF - END SUBROUTINE READ_RAD_IC - - MODULE DIAG_COM_RAD - IMPLICIT NONE - - INTEGER :: j_h2och4 = 1, j_pcldss = 1, j_pcldmc = 1, & - j_clddep = 1, j_pcld = 1, j_srincp0 = 1, & - j_srnfp0 = 1, j_srnfp1 = 1, j_srincg = 1, & - j_srnfg = 1, j_brtemp = 1, j_trincg = 1, j_hsurf = 1, & - j_hatm = 1, j_plavis = 1, j_planir = 1, j_albvis = 1, & - j_albnir = 1, j_srrvis = 1, j_srrnir = 1, & - j_sravis = 1, j_sranir = 1, j_trnfp0 = 1, & - j_trnfp1 = 1, j_clrtoa = 1, j_clrtrp = 1, & - j_tottrp = 1, jl_srhr = 1, jl_trcr = 1, & - jl_totcld = 1, jl_sscld = 1, jl_mccld = 1, & - jl_wcld = 1, jl_icld = 1, jl_wcod = 1, jl_icod = 1, & - jl_wcsiz = 1, jl_icsiz = 1, jl_wcldwt = 1, & - jl_icldwt = 1, ij_pmccld = 1, ij_trnfp0 = 1, & - ij_cldcv = 1, ij_pcldl = 1, ij_pcldm = 1, & - ij_pcldh = 1, ij_pcldl_ss = 1, ij_cldtppr = 1, & - ij_srvis = 1, ij_rnfp1 = 1, ij_srnfp0 = 1, & - ij_srincp0 = 1, ij_srnfg = 1, ij_srincg = 1, & - ij_btmpw = 1, ij_srref = 1, ij_frmp = 1, & - ij_clr_srincg = 1, ij_CLDTPT = 1, ij_cldt1t = 1, & - ij_cldt1p = 1, ij_cldcv1 = 1, ij_wtrcld = 1, & - ij_icecld = 1, ij_optdw = 1, ij_optdi = 1, & - ij_swcrf = 1, ij_lwcrf = 1, ij_srntp = 1, & - ij_trntp = 1, ij_clr_srntp = 1, ij_clr_trntp = 1, & - ij_clr_srnfg = 1, ij_clr_trdng = 1, & - ij_clr_sruptoa = 1, ij_clr_truptoa = 1, & - ij_swdcls = 1, ij_swncls = 1, ij_lwdcls = 1, & - ij_swnclt = 1, ij_lwnclt = 1, ij_srvdir = 1, & - ij_srvissurf = 1, ij_chl = -1, ij_swaerrf = 1, & - ij_lwaerrf = 1, ij_swaersrf = 1, ij_lwaersrf = 1, & - ij_swaerrfnt = 1, ij_lwaerrfnt = 1, & - ij_swaersrfnt = 1, ij_lwaersrfnt = 1, ij_swcrf2 = 1, & - ij_lwcrf2 = 1, ij_siswd = 1, ij_siswu = 1, & - ij_lwprad = 1, ij_iwprad = 1, ij_h2och4 = 1, & - ij_sw_cs_noa = 1, ij_lw_cs_noa = 1, ij_sw_as_noa = 1, & - ij_lw_as_noa = 1, ijl_rc = 1, ijl_cf = 1, & - ijl_QLrad = 1, ijl_QIrad = 1, ijl_wtrtau = 1, & - ijl_icetau = 1, idd_cl7 = 1, idd_ccv = 1, & - idd_isw = 1, idd_palb = 1, idd_galb = 1, idd_aot = 1, & - idd_aot2 = 1, idd_absa = 1 - -#ifdef HEALY_LM_DIAGS - INTEGER :: j_vtau = 1, j_ghg = 1 -#endif - -#if ( defined TRACERS_GC ) -!@var GEOS-Chem radiative forcing diagnostics -! First index is: -! 1=SW, 2=LW -! Second index is: -! 1 = CH4; 2 = N2O; 3 = CFC11; 4 = CFC12 -! 5 = O3; 6 = SO4; 7 = NIT; 8 = BCO; 9 = BCI -! 10 = OCO; 11 = OCI; 12 = SOA - INTEGER, DIMENSION(2,5) :: ij_fcghg -#elif ( defined ACCMIP_LIKE_DIAGS ) -!@var IJ_fcghg GHG forcing diagnostics (2=LW,SW, 4=CH4,N2O,CFC11,CFC12) - INTEGER, DIMENSION(2,4) :: ij_fcghg -#endif - END MODULE DIAG_COM_RAD diff --git a/model/RAD2_DRV.F90 b/model/RAD2_DRV.F90 deleted file mode 100644 index 020c790..0000000 --- a/model/RAD2_DRV.F90 +++ /dev/null @@ -1,7000 +0,0 @@ -#include "rundeck_opts.h" - -#ifdef SKIP_TRACERS_RAD -#undef TRACERS_ON -#endif - -!@sum RAD_DRV contains drivers for the radiation related routines -!@ver 2009/05/11 -!@cont init_RAD, RADIA -!**** semi-random cloud overlap (computed opt.d+diagn) -!**** to be used with R99E or later radiation routines. carbon/2 -!**** - -SUBROUTINE CALC_ZENITH_ANGLE - !@sum calculate zenith angle for current time step - !@auth Gavin Schmidt (from RADIA) - USE CONSTANT, ONLY : twopi - USE MODEL_COM, ONLY : itime, nday, dtsrc, calendar - USE TIMECONSTANTS_MOD, ONLY : SECONDS_PER_DAY - USE RAD_COM, ONLY : cosz1 - USE RAD_COSZ0, ONLY : COSZT - USE TIMEINTERVAL_MOD - - IMPLICIT NONE - - INTEGER JTIME - REAL*8 ROT1, ROT2 - TYPE (TIMEINTERVAL) :: sPerDay - - JTIME = MOD(ITIME,NDAY) - ROT1 = (TWOPI*JTIME)/NDAY - sPerDay = calendar%GETSECONDSPERDAY() - ROT2 = ROT1 + TWOPI*DTsrc/REAL(sPerDay) - - CALL COSZT(ROT1,ROT2,COSZ1) - -END SUBROUTINE CALC_ZENITH_ANGLE - -SUBROUTINE INIT_RAD( istart ) - !@sum init_RAD initialises radiation code - !@auth Original Development Team - !@calls RADPAR : RCOMP1, ORBPAR - USE FILEMANAGER - USE RUNTIMECONTROLS_MOD, ONLY : tracers_minerals - USE DICTIONARY_MOD - USE CONSTANT, ONLY : GRAV, BYSHA, TWOPI, planet_name - USE RESOLUTION, ONLY : jm, lm, psf - USE ATM_COM, ONLY : t, pk, kradia, lm_req - USE MODEL_COM, ONLY : DTSRC, IYEAR1, MODELECLOCK, master_yr - USE MODEL_COM, ONLY : orbit - USE ATM_COM, ONLY : pednl00 - USE DOMAIN_DECOMP_ATM, ONLY : grid, WRITE_PARALLEL, AM_I_ROOT, & - READT_PARALLEL, GETDOMAINBOUNDS -#ifndef CUBED_SPHERE - USE GEOM, ONLY : lat_dg -#endif - - USE RADPAR, ONLY : PTLISO, KTREND, LMR => NL, PLB, & - LS1_loc, planck_tmin, planck_tmax, & - transmission_corrections, KCLDEM, & - KSIALB, KSOLAR, SHL, snoage_fac_max, & - KZSNOW, KYEARS, KJDAYS, MADLUV, & - KYEARG, KJDAYG, MADGHG, KYEARO, & - KJDAYO, MADO3M, KYEARA, KJDAYA, & - MADAER, KYEARD, KJDAYD, MADDST, & - KYEARV, KJDAYV, MADVOL, KYEARE, & - KJDAYE, MADEPS, KYEARR, KJDAYR, & - ITR, nraero_aod => NTRACE, FS8OPX, & - FT8OPX, TRRDRY, KRHTRA, TRADEN, & - REFDRY, RCOMP1, WRITER, WRITET, & - FSTASC, FTTASC - - ! turning on options for extra aerosols -#ifdef ALTER_RADF_BY_LAT - USE RADPAR, ONLY : FS8OPX_orig, FT8OPX_orig -#endif - -#ifdef TRACERS_SPECIAL_Shindell - USE PHOTOLYSIS, ONLY : aer2, miedx2, nbfastj -#endif - -#ifdef TRACERS_ON - USE RAD_COM, ONLY : nraero_rf, nraero_seasalt, nraero_koch, & - nraero_nitrate, nraero_dust, & - nraero_OMA, nraero_AMP, nraero_TOMAS -#endif - - USE RAD_COM, ONLY : rqt, s0x, co2x, n2ox, ch4x, cfc11x, & - cfc12x, xGHGx, o2x, no2x, n2cx, yGHGx, & - so2x, CH4X_RADoverCHEM, snoage_def, & - s0_yr, s0_day, ghg_yr, ghg_day, volc_yr,& - volc_day, aero_yr, dust_yr, O3_yr, & - H2ObyCH4, dH2O, h2ostratx, O3x, RHfix, & - CLDx, ref_mult, COSZ1, OBLIQ, ECCN, & - OMEGT, OBLIQ_DEF, ECCN_DEF, OMEGT_DEF, & - CC_cdncx, OD_cdncx, cdncl, pcdnc, vcdnc,& - cloud_rad_forc, TAero_aod_diag, & - aer_rad_forc, PLB0, SHL0, albsn_yr, & - dALBsnX, nradfrc, rad_interact_aer, & - clim_interact_chem, rad_forc_lev, & - ntrix_aod, ntrix_rf, wttr, & - variable_orb_par, orb_par_year_bp, & - orb_par, nrad, RADIATIONSETORBIT, & - chl_from_obio, chl_from_seawifs - -#ifdef TRACERS_ON - USE RAD_COM, ONLY : njaero, nraero_aod_rsf, nraero_rf_rsf, & - tau_as, tau_cs, tau_dry -#ifdef CACHED_SUBDD - USE RAD_COM, ONLY : abstau_as, abstau_cs, abstau_dry, & - swfrc, lwfrc -#endif -#endif - - USE RAD_COSZ0, ONLY : COSZ_INIT - USE CLOUDS_COM, ONLY : llow - USE DIAG_COM, ONLY : IWRITE, JWRITE, ITWRITE - -#ifdef ALTER_RADF_BY_LAT - USE RAD_COM, ONLY : FULGAS_lat, FS8OPX_lat, FT8OPX_lat -#endif - -#ifdef TRACERS_ON - USE DIAG_COM, ONLY : save3dAOD - USE TRACER_COM, ONLY : NTM - USE TRACER_COM, ONLY : n_BCIA, n_BCB, n_NO3p - USE TRACER_COM, ONLY : n_Clay, n_Silt1, n_Silt2, n_Silt3, & - n_Silt4, n_Silt5 - USE TRACER_COM, ONLY : n_SO4, n_Seasalt1, n_Seasalt2 - USE TRACER_COM, ONLY : n_OCB, n_OCIA, n_Isopp1a, n_SO4 - USE TRACER_COM, ONLY : n_vbsAm2 - USE RAD_COM, ONLY : diag_fc - USE TRDIAG_COM, ONLY : save_dry_aod -#ifdef TRACERS_TOMAS - USE TRACER_COM, ONLY : N_ASO4, N_ANACL, N_AECOB, N_AECIL, & - N_AOCOB, N_AOCIL, N_ADUST -#endif -#endif - -#if (defined TRACERS_DUST) || (defined TRACERS_MINERALS) - USE OLDTRACER_MOD, ONLY : TRPDENS - USE TRDUST_MOD, ONLY : imDust, nSubClays, dryEffRadMinerals, & - SUBCLAYWEIGHTS - USE TRDUST_DRV, ONLY : CALCSUBCLAYWEIGHTS - USE TRACER_COM, ONLY : ntm_clay, ntm_sil1, ntm_sil2, ntm_sil3, & - ntm_sil4, ntm_sil5, N_SOILDUST - USE RAD_COM, ONLY : nr_soildust -#endif - -#ifdef TRACERS_MINERALS - USE TRACER_COM, ONLY : n_clayilli, n_claykaol, n_claysmec, & - n_claycalc, n_clayquar, n_clayfeld, & - n_clayhema, n_claygyps, n_clayilhe, & - n_claykahe, n_claysmhe, n_claycahe, & - n_clayquhe, n_clayfehe, n_claygyhe, & - n_sil1quar, n_sil1feld, n_sil1calc, & - n_sil1illi, n_sil1kaol, n_sil1smec, & - n_sil1hema, n_sil1gyps, n_sil1quhe, & - n_sil1fehe, n_sil1cahe, n_sil1gyhe, & - n_sil1ilhe, n_sil1kahe, n_sil1smhe, & - n_sil2quar, n_sil2feld, n_sil2calc, & - n_sil2hema, n_sil2gyps, n_sil2illi, & - n_sil2kaol, n_sil2smec, n_sil2quhe, & - n_sil2fehe, n_sil2cahe, n_sil2gyhe, & - n_sil2ilhe, n_sil2kahe, n_sil2smhe, & - n_sil3quar, n_sil3feld, n_sil3calc, & - n_sil3hema, n_sil3gyps, n_sil3illi, & - n_sil3kaol, n_sil3smec, n_sil3quhe, & - n_sil3fehe, n_sil3cahe, n_sil3gyhe, & - n_sil3ilhe, n_sil3kahe, n_sil3smhe, & - n_sil4quar, n_sil4feld, n_sil4calc, & - n_sil4hema, n_sil4gyps, n_sil4illi, & - n_sil4kaol, n_sil4smec, n_sil4quhe, & - n_sil4fehe, n_sil4cahe, n_sil4gyhe, & - n_sil4ilhe, n_sil4kahe, n_sil4smhe, & - n_sil5quar, n_sil5feld, n_sil5calc, & - n_sil5hema, n_sil5gyps, n_sil5illi, & - n_sil5kaol, n_sil5smec, n_sil5quhe, & - n_sil5fehe, n_sil5cahe, n_sil5gyhe, & - n_sil5ilhe, n_sil5kahe, n_sil5smhe -#endif - -#ifdef TRACERS_AMP - USE AERO_CONFIG, ONLY : nmodes - USE TRACER_COM, ONLY : n_N_AKK_1, n_N_ACC_1, n_N_DD1_1, & - n_N_DS1_1, n_N_DD2_1, n_N_DS2_1, & - n_N_SSA_1, n_N_SSC_1, n_N_OCC_1, & - n_N_BC1_1, n_N_BC2_1, n_N_BC3_1, & - n_N_DBC_1, n_N_BOC_1, n_N_BCS_1, & - n_N_MXX_1 -#endif - -#ifdef TRACERS_TOMAS - USE TOMAS_AEROSOL, ONLY : icomp -#endif - - USE AERPARAM_MOD, ONLY : aermix - -#ifdef OLD_BCdalbsn - USE AERPARAM_MOD, ONLY : depoBC, depoBC_1990 -#endif - - USE ABSTRACTORBIT_MOD, ONLY : ABSTRACTORBIT - - ! begin section for radiation-only SCM - USE CONSTANT, ONLY : gasc, tf, mair, mwat, pi, lhe, lhs, & - mb2kg, kg2mb, kapa - USE ATM_COM, ONLY : q, p, PMID, pedn, PDSIG, pek, MA, BYMA, & - ltropo - USE ATM_COM, ONLY : AML00, BYAML00, req_fac, kradia, lm_req - USE RESOLUTION, ONLY : im, plbot, ls1 => LS1_NOMINAL - USE RESOLUTION, ONLY : MFIX, MFRAC - -#ifndef STDHYB - USE RESOLUTION, ONLY : mfixs, mtop -#endif - - USE RAD_COM, ONLY : modrd - USE RADPAR, ONLY : u0gas, ulgas, set_gases_internally - USE RADPAR, ONLY : set_aerosols_internally, sraext, srasct, & - sragcb, srdext, srdsct, srdgcb, srvext, & - srvsct, srvgcb, srbext, srbsct, srbgcb, & - traalk, trdalk, trvalk, trbalk - USE RADPAR, ONLY : keepal, srbalb, srxalb, FSTOPX, FTTOPX - USE RADPAR, ONLY : skip_AOD_in_rad - USE PARIO, ONLY : PAR_OPEN, PAR_CLOSE, READ_DATA, READ_DIST_DATA - USE FLUXES, ONLY : atmsrf, ASFLX4, focean, fland, flice - USE FLUXES, ONLY : atmocn, atmice, atmgla, atmlnd - USE GHY_COM, ONLY : fearth - USE LAKES_COM, ONLY : flake - USE SEAICE_COM, ONLY : si_atm - USE CLOUDS_COM, ONLY : SVLHX, SVLAT, RHSAV - ! end section for radiation-only SCM - -#ifdef GCAP - USE RAD_COM, ONLY : SAVE_COSZ2 -#endif - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: istart - - INTEGER L, LR, n1, n, nn, iu2 - REAL*8 PLBx(LM+1), pyear - - !@var NRFUN indices of unit numbers for radiation routines - INTEGER NRFUN(14), IU, DONOTREAD - - !@var RUNSTR names of files for radiation routines - CHARACTER*5 :: RUNSTR(14) = & - (/ "RADN1", "RADN2", "RADN3", "RADN4", "RADN5", & - "RADN6", "RADN7", "RADN8", "RADN9", "RADNA", & - "RADNB", "RADNC", "RADND", "RADNE" /) - - !@var QBIN true if files for radiation input files are binary - LOGICAL :: QBIN(14) = & - (/ .TRUE., .TRUE., .FALSE., .TRUE., .TRUE., & - .TRUE., .TRUE., .TRUE., .FALSE., .TRUE., & - .TRUE., .TRUE., .TRUE., .TRUE. /) - -#ifdef TRACERS_MINERALS - REAL(KIND=8) :: densclay(4*ntm_clay), denssil1(ntm_sil1), & - denssil2(ntm_sil2), denssil3(ntm_sil3), & - denssil4(ntm_sil4), denssil5(ntm_sil5) -#endif - - CHARACTER(LEN=300) :: out_line - CHARACTER*6 :: skip - - ! begin section for radiation-only SCM - REAL*8 :: cosz_const, mvar - CHARACTER(LEN=6) :: gasnames(13) - INTEGER :: fid, igas - REAL*8 :: szadeg, s0cosz, s0_tmp, cosz_tmp, tloc - INTEGER :: rad_scm_int - LOGICAL :: rad_scm = .FALSE. - - REAL*8 QSAT ! external function - ! end section for radiation-only SCM - - INTEGER :: I, J - INTEGER :: I_0, I_1, J_0, J_1 - INTEGER :: I_0H, I_1H - INTEGER :: J_0H, J_1H - - !**** sync radiation parameters from input - CALL SYNC_PARAM("NRAD",NRAD) - - IF ( IS_SET_PARAM("variable_orb_par") ) THEN - CALL GET_PARAM("variable_orb_par",variable_orb_par) - ELSEIF ( master_yr==0 ) THEN - variable_orb_par = 1 - ELSE - variable_orb_par = 0 - ENDIF - - IF ( IS_SET_PARAM("orb_par_year_bp") ) THEN - CALL GET_PARAM("orb_par_year_bp",orb_par_year_bp) - ELSEIF ( master_yr==0 ) THEN - orb_par_year_bp = 0 - ELSE - orb_par_year_bp = 1950 - master_yr - ENDIF - - CALL SYNC_PARAM("orb_par",orb_par,3) - CALL SYNC_PARAM("S0X",S0X) - CALL SYNC_PARAM("CO2X",CO2X) ! fulgas(2) - CALL SYNC_PARAM("O2X",O2X) ! fulgas(4) - CALL SYNC_PARAM("NO2X",NO2X) ! fulgas(5) - CALL SYNC_PARAM("N2OX",N2OX) ! fulgas(6) - CALL SYNC_PARAM("CH4X",CH4X) ! fulgas(7) - CALL SYNC_PARAM("CH4X_RADoverCHEM",CH4X_RADoverCHEM) - CALL SYNC_PARAM("CFC11X",CFC11X) ! fulgas(8) - CALL SYNC_PARAM("CFC12X",CFC12X) ! fulgas(9) - CALL SYNC_PARAM("N2CX",N2CX) ! fulgas(10) - CALL SYNC_PARAM("XGHGX",XGHGX) ! fulgas(11) - CALL SYNC_PARAM("YGHGX",YGHGX) ! fulgas(12) - CALL SYNC_PARAM("SO2X",SO2X) ! fulgas(13) - CALL SYNC_PARAM("H2OstratX",H2OstratX) ! fulgas(1) - CALL SYNC_PARAM("O3X",O3X) ! fulgas(3) - CALL SYNC_PARAM("CLDX",CLDX) - CALL SYNC_PARAM("H2ObyCH4",H2ObyCH4) - CALL GET_PARAM("S0_yr",S0_yr,DEFAULT=master_yr) - - IF ( IS_SET_PARAM("S0_day") ) THEN - CALL GET_PARAM("S0_day",S0_day) - ELSE - IF ( s0_yr==0 ) s0_day = 0 - ! else use default value - ENDIF - - CALL GET_PARAM("ghg_yr",ghg_yr,DEFAULT=master_yr) - IF ( IS_SET_PARAM("ghg_day") ) THEN - CALL GET_PARAM("ghg_day",ghg_day) - ELSE - IF ( ghg_yr==0 ) ghg_day = 0 - ! else use default value - ENDIF - - CALL GET_PARAM("volc_yr",volc_yr,DEFAULT=master_yr) - IF ( IS_SET_PARAM("volc_day") ) THEN - CALL GET_PARAM("volc_day",volc_day) - ELSE - IF ( volc_yr==0 ) volc_day = 0 - ! else use default value - ENDIF - - CALL GET_PARAM("aero_yr",aero_yr,DEFAULT=master_yr) - CALL GET_PARAM("dust_yr",dust_yr,DEFAULT=master_yr) - CALL SYNC_PARAM("dALBsnX",dALBsnX) - CALL GET_PARAM("albsn_yr",albsn_yr,DEFAULT=master_yr) - CALL SYNC_PARAM("aermix",aermix,13) - CALL SYNC_PARAM("REFdry",REFdry,8) - CALL SYNC_PARAM("FS8OPX",FS8OPX,8) - CALL SYNC_PARAM("FT8OPX",FT8OPX,8) - CALL SYNC_PARAM("RHfix",RHfix) - CALL SYNC_PARAM("CC_cdncx",CC_cdncx) - CALL SYNC_PARAM("OD_cdncx",OD_cdncx) - CALL GET_PARAM("O3_yr",O3_yr,DEFAULT=master_yr) - - IF ( planet_name/='Earth' ) PTLISO = .015D0*psf - ! reasonable default - - CALL SYNC_PARAM("PTLISO",PTLISO) - CALL SYNC_PARAM("KSOLAR",KSOLAR) - CALL SYNC_PARAM("KSIALB",KSIALB) - CALL SYNC_PARAM("KZSNOW",KZSNOW) - CALL SYNC_PARAM("snoage_def",snoage_def) - CALL SYNC_PARAM("snoage_fac_max",snoage_fac_max) - CALL SYNC_PARAM("nradfrc",nradfrc) - IF ( snoage_fac_max<0. .OR. snoage_fac_max>1. ) THEN - WRITE (out_line,*) 'set 00 .AND. chl_from_seawifs>0 ) & - CALL STOP_MODEL("Make your mind which chl to use",255) - - IF ( istart == 2 ) THEN - ! replace with cold vs warm start logic - !**** SET RADIATION EQUILIBRIUM TEMPERATURES FROM LAYER LM TEMPERATURE - DO J = J_0, J_1 - DO I = I_0, I_1 - RQT( : ,I,J) = T(I,J,LM)*PK(LM,I,J) - ENDDO - ENDDO - ENDIF - - - !**** - !**** SET THE CONTROL PARAMETERS FOR THE RADIATION (need mean pressures) - !**** - LMR = LM + LM_REQ - PLB(1:LMR+1) = PEDNL00(1:LMR+1) - DO L = 1, LM - PLBx(L) = PLB(L) ! needed for CH4 prod. H2O - ENDDO - PLBx(LM+1) = 0. - DO LR = LM + 1, LMR - PLB0(LR-LM) = PLB(LR+1) - ENDDO - cdncl = 0 - CALL RETERP(vcdnc,pcdnc,7,cdncl,plb,llow+2) - - KTREND = 1 ! GHgas trends are determined by input file - !note KTREND=0 is a possible but virtually obsolete option - !**** - ! Model Add-on Data of Extended Climatology Enable Parameter - ! MADO3M = -1 Reads Ozone data the GCM way - ! MADAER = 1 Reads Tropospheric Aerosol climatology 1850-2050 - ! MADAER = 3 uses Koch,Bauer 2008 aerosol climatology 1890-2000 - ! MADDST = 1 Reads Dust-windblown mineral climatology RFILE6 - ! MADVOL = 1 Reads Volcanic 1950-00 aerosol climatology RFILE7 - ! MADEPS = 1 Reads Epsilon cloud heterogeniety data RFILE8 - ! MADLUV = 1 Reads Lean''s SolarUV 1882-1998 variability RFILE9 - !**** Radiative forcings are either constant = obs.value at given yr/day - !**** or time dependent (year=0); if day=0 an annual cycle is used - !**** even if the year is fixed - KYEARS = s0_yr - KJDAYS = s0_day - MADLUV = 1 ! solar 'constant' - KYEARG = ghg_yr - KJDAYG = ghg_day ! well-mixed GHGases - -#ifndef ALTER_RADF_BY_LAT - IF ( ghg_yr>0 ) MADGHG = 0 ! skip GHG-updating -#endif - - KYEARO = O3_yr - KJDAYO = 0 - MADO3M = -1 ! ozone (ann.cycle) - IF ( KYEARO>0 ) KYEARO = -KYEARO ! use ONLY KYEARO-data - KYEARA = Aero_yr - KJDAYA = 0 ! MADAER=1 or 3, trop.aeros (ann.cycle) - IF ( KYEARA>0 ) KYEARA = -KYEARA ! use ONLY KYEARA-data - IF ( FILE_EXISTS('TAero_SSA') ) MADAER = 3 - ! one of the TAero_XXX set - KYEARD = Dust_yr - IF ( KYEARD>0 ) KYEARD = -KYEARD ! use ONLY KYEARD-data - KYEARV = Volc_yr - KJDAYV = Volc_day - IF ( FILE_EXISTS('RADN7') ) MADVOL = 1 - ! Volc. Aerosols - CALL SYNC_PARAM("MADVOL",MADVOL) - !*** KYEARV=0 : use current year - !*** KYEARV<0 : use long term mean stratospheric aerosols (use -1) - ! Hack : KYEARV= -2000 and -2010 were used for 2 specific runs that - ! ended in 2100 and repeated some 20th century volcanos - !*** KYEARV=-2000 : use volcanos from 100 yrs ago after 2000 - !*** KYEARV=-2010 : repeat 2nd half, then first half of 20th century - IF ( KYEARV<=-2000 ) KYEARV = 0 - ! use current year (before 2000) - !**** NO time history (yet), except for ann.cycle, for forcings below; - !**** if KJDAY?=day0 (1->365), data from that day are used all year - KYEARE = 0 - KJDAYE = 0 - KYEARR = 0 - KJDAYR = 0 ! surf.reflectance (ann.cycle) - KCLDEM = 1 ! 0 : old 1 : new LW cloud scattering scheme - - IF ( FILE_EXISTS('DUSTaer') ) MADDST = 1 - ! Desert dust - IF ( FILE_EXISTS('RADN8') ) MADEPS = 1 ! cloud Epsln - KCLDEP - transmission_corrections = FILE_EXISTS('RADN4') - - !**** Aerosols : - !**** Currently there are five different default aerosol controls - !**** 1 : total 2 : background+tracer 3 : Climatology 4 : dust 5 : volcanic - !**** By adjusting FSXAER,FTXAER you can remove the default - !**** aerosols and replace them with your version if required - !**** (through TRACER in RADIA). - !**** FSXAER is for the shortwave, FTXAER is for the longwave effects - !aer FSXAER = (/ 1.,1.,1.,1.,1. /) ; FTXAER = (/ 1.,1.,1.,1.,1. /) - - !**** climatology aerosols are grouped into 6 types from 13 sources : - !**** Pre-Industrial+Natural 1850 Level Industrial Process BioMBurn - !**** --------------------------------- ------------------ -------- - !**** 1 2 3 4 5 6 7 8 9 10 11 12 13 - !**** SNP SBP SSP ANP ONP OBP BBP SUI ANI OCI BCI OCB BCB - !**** using the following default scaling/tuning factors AERMIX(1-13) - !**** 1.0, 1.0, .26, 1.0, 2.5, 2.5, 1.9, 1.0, 1.0, 2.5, 1.9, 2.5, 1.9 - !**** The 8 groups are (adding dust and volcanic aerosols as 7. and 8.) - !**** 1. Sulfates (industr and natural), 2. Sea Salt, 3. Nitrates - !**** 4. Organic Carbons, 5. industr Black Carbons(BC), 6. Biomass BC - !**** 7. Dust aerosols, 8. Volcanic aerosols - !**** use FS8OPX and FT8OPX to enhance the optical effect; defaults : - !aer FS8OPX = (/1., 1., 1., 1., 2., 2., 1. , 1./) solar - !aer FT8OPX = (/1., 1., 1., 1., 1., 1., 1.3d0, 1./) thermal -!!!!! Note : FS|T8OPX(7-8) makes FS|TXAER(4-5) redundant. - !**** Particle sizes of the first 4 groups have RelHum dependence - - !**** To add up to 8 further aerosols : - !**** 1) set nraero_aod to the number of extra aerosol fields - !**** 2) ITR defines which set of Mie parameters get used, choose - !**** from the following : - !**** 1 SO4, 2 seasalt, 3 nitrate, 4 OCX organic carbons - !**** 5 BCI, 6 BCB, 7 dust, 8 H2SO4 volc - !**** 2b) set up the indexing array ntrix_aod to map the RADIATION tracers - !**** to the main model tracers - !**** 2c) set up the weighting array WTTR to weight main model tracers, - !**** if needed (default value is 1). - !**** - !**** 3) Use FSTOPX/FTTOPX(1 : nraero_aod) to scale them in RADIA - !**** 4) Set TRRDRY to dry radius - !**** 5) Set KRHTRA=1 if aerosol has RH dependence, 0 if not - !**** Note : whereas FSXAER/FTXAER are global (shared), FSTOPX/FTTOPX - !**** have to be reset for each grid box to allow for the way it - !**** is used in RADIA (TRACERS_AEROSOLS_Koch) - !aer nraero_aod = 0 - !aer ITR = (/ 0,0,0,0, 0,0,0,0 /) - !aer TRRDRY=(/ .1d0, .1d0, .1d0, .1d0, .1d0, .1d0, .1d0, .1d0/) - !aer KRHTRA=(/1,1,1,1,1,1,1,1/) - -#if defined( TRACERS_ON ) - -#if defined( TRACERS_AMP ) - nraero_AMP = nmodes - IF ( diag_fc==2 ) THEN - nraero_rf = nraero_rf + nraero_AMP - ELSEIF ( diag_fc==1 ) THEN - IF ( nraero_AMP>0 ) nraero_rf = nraero_rf + 1 - ENDIF -#elif defined( TRACERS_TOMAS ) - !TOMAS does not include NO3 AND VOL, which use its default radiation. -#ifndef TRACERS_NITRATE - nraero_TOMAS = icomp - 2 -#else - nraero_TOMAS = icomp - 1 -#endif - IF ( diag_fc==2 ) THEN - nraero_rf = nraero_rf + nraero_TOMAS - ELSEIF ( diag_fc==1 ) THEN - IF ( nraero_TOMAS>0 ) nraero_rf = nraero_rf + 1 - ENDIF -#else - nraero_OMA = nraero_seasalt + nraero_koch + nraero_nitrate + & - nraero_dust - IF ( diag_fc==2 ) THEN - nraero_rf = nraero_rf + nraero_OMA - ELSEIF ( diag_fc==1 ) THEN - IF ( nraero_OMA>0 ) nraero_rf = nraero_rf + 1 - ENDIF -#endif - - nraero_aod = nraero_OMA + nraero_AMP + nraero_TOMAS - - IF ( nraero_aod_rsf>0 ) THEN - IF ( nraero_aod_rsf/=nraero_aod ) & - CALL STOP_MODEL('nraero_aod_rsf /= nraero_aod',255) - ENDIF - - IF ( nraero_rf_rsf>0 ) THEN - IF ( nraero_rf_rsf/=nraero_rf ) & - CALL STOP_MODEL('nraero_rf_rsf /= nraero_rf',255) - ENDIF - - IF ( nraero_aod>0 ) THEN - ALLOCATE (ntrix_aod(nraero_aod)) - ntrix_aod = 0 - IF ( nraero_rf>0 ) ALLOCATE (ntrix_rf(nraero_rf)) - ntrix_rf = 0 - ALLOCATE (wttr(nraero_aod)) - wttr = 1. - - IF ( .NOT.ALLOCATED(tau_as) ) THEN - ALLOCATE (tau_as(I_0H : I_1H,J_0H : J_1H,lm,nraero_aod)) - ALLOCATE (tau_cs(I_0H : I_1H,J_0H : J_1H,lm,nraero_aod)) - tau_as = 0.D0 - tau_cs = 0.D0 - IF ( save_dry_aod>0 ) THEN - ALLOCATE (tau_dry(I_0H : I_1H,J_0H : J_1H,lm,nraero_aod)) - tau_dry = 0.D0 - ENDIF -#ifdef CACHED_SUBDD - ALLOCATE (abstau_as(I_0H : I_1H,J_0H : J_1H,lm,nraero_aod)) - ALLOCATE (abstau_cs(I_0H : I_1H,J_0H : J_1H,lm,nraero_aod)) - abstau_as = 0.D0 - abstau_cs = 0.D0 - IF ( save_dry_aod>0 ) THEN - ALLOCATE (abstau_dry(I_0H : I_1H,J_0H : J_1H,lm,nraero_aod)) - abstau_dry = 0.D0 - ENDIF - IF ( nraero_rf>0 ) THEN - ALLOCATE (swfrc(I_0H : I_1H,J_0H : J_1H,nraero_rf)) - ALLOCATE (lwfrc(I_0H : I_1H,J_0H : J_1H,nraero_rf)) - swfrc = 0.D0 - lwfrc = 0.D0 - ENDIF -#endif /* CACHED_SUBDD */ - ENDIF - ENDIF -#ifdef TRACERS_SPECIAL_Shindell -#if (! defined(TRACERS_AMP)) & (! defined(TRACERS_TOMAS)) - njaero = nraero_aod + 2 -#else - njaero = 2 -#endif - ALLOCATE (miedx2(nbfastj,njaero)) - ALLOCATE (aer2(nbfastj,njaero)) -#endif /* TRACERS_SPECIAL_Shindell */ - - !======================================================================= - ! Define indices to map model aerosol tracer arrays to radiation arrays - ! and other radiation-related aerosol properties - !======================================================================= - n = 0 - !----------------------------------------------------------------------- -#ifdef TRACERS_AEROSOLS_SEASALT - IF ( nraero_seasalt>0 ) THEN - IF ( rad_interact_aer>0 ) THEN - FS8OPX(2) = 0.D0 - FT8OPX(2) = 0.D0 - ENDIF - ntrix_aod(n+1 : n+nraero_seasalt) = (/n_seasalt1,n_seasalt2/) - trrdry(n+1 : n+nraero_seasalt) = (/0.44D0,1.7D0/) - itr(n+1 : n+nraero_seasalt) = (/2,2/) - ENDIF - n = n + nraero_seasalt -#endif /* TRACERS_AEROSOLS_SEASALT */ - !----------------------------------------------------------------------- -#ifdef TRACERS_AEROSOLS_Koch - IF ( nraero_koch>0 ) THEN - IF ( rad_interact_aer>0 ) THEN ! if BC''s sol.effect are doubled : - FS8OPX(1) = 0.D0 - FT8OPX(1) = 0.D0 -#ifndef SULF_ONLY_AEROSOLS - FS8OPX(4 : 6) = 0.D0 - FT8OPX(4 : 6) = 0.D0 -#endif - ENDIF - ntrix_aod(n+1) = n_SO4 - trrdry(n+1) = 0.15D0 - itr(n+1) = 1 - -#ifndef SULF_ONLY_AEROSOLS - -#if defined( TRACERS_AEROSOLS_VBS ) & defined( TRACERS_AEROSOLS_SOA ) - - ntrix_aod(n+2 : n+nraero_koch) = (/n_vbsAm2,n_isopp1a,n_BCIA, & - n_BCB/) - trrdry(n+2 : n+nraero_koch) = (/0.2D0,0.2D0,0.08D0,0.08D0/) - itr(n+2 : n+nraero_koch) = (/4,5,6/) - krhtra(n+2 : n+nraero_koch) = (/1,0,0/) - ! Augment BC by 50 % - fstasc(n+2 : n+nraero_koch) = (/1.D0,1.5D0,1.5D0/) - -#elif defined( TRACERS_AEROSOLS_VBS ) - - ntrix_aod(n+2 : n+nraero_koch) = (/n_vbsAm2,n_BCIA,n_BCB/) - trrdry(n+2 : n+nraero_koch) = (/0.2D0,0.08D0,0.08D0/) - itr(n+2 : n+nraero_koch) = (/4,5,6/) - krhtra(n+2 : n+nraero_koch) = (/1,0,0/) - ! Augment BC by 50 % - fstasc(n+2 : n+nraero_koch) = (/1.D0,1.5D0,1.5D0/) - -#elif defined( TRACERS_AEROSOLS_SOA ) - - ntrix_aod(n+2 : n+nraero_koch) = (/n_OCIA,n_OCB,n_isopp1a,n_BCIA,& - n_BCB/) - trrdry(n+2 : n+nraero_koch) = (/0.2D0,0.2D0,0.2D0,0.08D0,0.08D0/) - itr(n+2 : n+nraero_koch) = (/4,4,5,6/) - krhtra(n+2 : n+nraero_koch) = (/1,1,0,0/) - ! Augment BC by 50 % - fstasc(n+2 : n+nraero_koch) = (/1.D0,1.D0,1.5D0,1.5D0/) - -#else - - ntrix_aod(n+2 : n+nraero_koch) = (/n_OCIA,n_OCB,n_BCIA,n_BCB/) - trrdry(n+2 : n+nraero_koch) = (/0.2D0,0.2D0,0.08D0,0.08D0/) - itr(n+2 : n+nraero_koch) = (/4,4,5,6/) - krhtra(n+2 : n+nraero_koch) = (/1,1,0,0/) - ! Augment BC by 50 % - fstasc(n+2 : n+nraero_koch) = (/1.D0,1.D0,1.5D0,1.5D0/) - -#endif - -#endif /* SULF_ONLY_AEROSOLS */ - ENDIF - n = n + nraero_koch -#endif /* TRACERS_AEROSOLS_Koch */ - !----------------------------------------------------------------------- -#ifdef TRACERS_NITRATE - IF ( nraero_nitrate>0 ) THEN -#ifdef SULF_ONLY_AEROSOLS - CALL STOP_MODEL('SULF_ONLY_AEROSOLS and TRACERS_NITRATE on', & - 255) -#endif /* OFF : SULF_ONLY_AEROSOLS */ - IF ( rad_interact_aer>0 ) THEN - ! turn off default nitrate - FS8OPX(3) = 0.D0 - FT8OPX(3) = 0.D0 - ENDIF - ntrix_aod(n+1 : n+nraero_nitrate) = (/n_NO3p/) - trrdry(n+1 : n+nraero_nitrate) = (/0.15D0/) - itr(n+1 : n+nraero_nitrate) = (/3/) - ENDIF - n = n + nraero_nitrate -#endif /* TRACERS_NITRATE */ - !----------------------------------------------------------------------- -#if (defined TRACERS_DUST) || (defined TRACERS_MINERALS) - IF ( nraero_dust>0 ) THEN - IF ( rad_interact_aer>0 ) THEN - ! turn off default dust - FS8OPX(7) = 0.D0 - FT8OPX(7) = 0.D0 - ENDIF - nr_soildust = n + 1 - -#ifdef TRACERS_MINERALS - -#if defined( TRACERS_DUST_Silt4 ) & defined( TRACERS_DUST_Silt5 ) - - ! Adjust if number of dust tracers changes. - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clayilli,i=1,nSubClays),( & - n_claykaol,i=1,nSubClays), & - (n_claysmec,i=1,nSubClays), & - (n_claycalc,i=1,nSubClays), & - (n_clayquar,i=1,nSubClays), & - (n_clayfeld,i=1,nSubClays), & - (n_clayhema,i=1,nSubClays), & - (n_claygyps,i=1,nSubClays), & - (n_clayilhe,i=1,nSubClays), & - (n_claykahe,i=1,nSubClays), & - (n_claysmhe,i=1,nSubClays), & - (n_claycahe,i=1,nSubClays), & - (n_clayquhe,i=1,nSubClays), & - (n_clayfehe,i=1,nSubClays), & - (n_claygyhe,i=1,nSubClays), & - n_sil1illi,n_sil1kaol, & - n_sil1smec,n_sil1calc, & - n_sil1quar,n_sil1feld, & - n_sil1hema,n_sil1gyps, & - n_sil1ilhe,n_sil1kahe, & - n_sil1smhe,n_sil1cahe, & - n_sil1quhe,n_sil1fehe, & - n_sil1gyhe,n_sil2illi, & - n_sil2kaol,n_sil2smec, & - n_sil2calc,n_sil2quar, & - n_sil2feld,n_sil2hema, & - n_sil2gyps,n_sil2ilhe, & - n_sil2kahe,n_sil2smhe, & - n_sil2cahe,n_sil2quhe, & - n_sil2fehe,n_sil2gyhe, & - n_sil3illi,n_sil3kaol, & - n_sil3smec,n_sil3calc, & - n_sil3quar,n_sil3feld, & - n_sil3hema,n_sil3gyps, & - n_sil3ilhe,n_sil3kahe, & - n_sil3smhe,n_sil3cahe, & - n_sil3quhe,n_sil3fehe, & - n_sil3gyhe,n_sil4illi, & - n_sil4kaol,n_sil4smec, & - n_sil4calc,n_sil4quar, & - n_sil4feld,n_sil4hema, & - n_sil4gyps,n_sil4ilhe, & - n_sil4kahe,n_sil4smhe, & - n_sil4cahe,n_sil4quhe, & - n_sil4fehe,n_sil4gyhe, & - n_sil5illi,n_sil5kaol, & - n_sil5smec,n_sil5calc, & - n_sil5quar,n_sil5feld, & - n_sil5hema,n_sil5gyps, & - n_sil5ilhe,n_sil5kahe, & - n_sil5smhe,n_sil5cahe, & - n_sil5quhe,n_sil5fehe, & - n_sil5gyhe/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - , & - (dryEffRadMinerals(8),i=1,ntm_sil4)& - , & - (dryEffRadMinerals(9),i=1,ntm_sil5)& - /) - - -#elif defined( TRACERS_DUST_Silt5 ) - - ! Adjust if number of dust tracers changes. - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clayilli,i=1,nSubClays),( & - n_claykaol,i=1,nSubClays), & - (n_claysmec,i=1,nSubClays), & - (n_claycalc,i=1,nSubClays), & - (n_clayquar,i=1,nSubClays), & - (n_clayfeld,i=1,nSubClays), & - (n_clayhema,i=1,nSubClays), & - (n_claygyps,i=1,nSubClays), & - (n_clayilhe,i=1,nSubClays), & - (n_claykahe,i=1,nSubClays), & - (n_claysmhe,i=1,nSubClays), & - (n_claycahe,i=1,nSubClays), & - (n_clayquhe,i=1,nSubClays), & - (n_clayfehe,i=1,nSubClays), & - (n_claygyhe,i=1,nSubClays), & - n_sil1illi,n_sil1kaol, & - n_sil1smec,n_sil1calc, & - n_sil1quar,n_sil1feld, & - n_sil1hema,n_sil1gyps, & - n_sil1ilhe,n_sil1kahe, & - n_sil1smhe,n_sil1cahe, & - n_sil1quhe,n_sil1fehe, & - n_sil1gyhe,n_sil2illi, & - n_sil2kaol,n_sil2smec, & - n_sil2calc,n_sil2quar, & - n_sil2feld,n_sil2hema, & - n_sil2gyps,n_sil2ilhe, & - n_sil2kahe,n_sil2smhe, & - n_sil2cahe,n_sil2quhe, & - n_sil2fehe,n_sil2gyhe, & - n_sil3illi,n_sil3kaol, & - n_sil3smec,n_sil3calc, & - n_sil3quar,n_sil3feld, & - n_sil3hema,n_sil3gyps, & - n_sil3ilhe,n_sil3kahe, & - n_sil3smhe,n_sil3cahe, & - n_sil3quhe,n_sil3fehe, & - n_sil3gyhe,n_sil5illi, & - n_sil5kaol,n_sil5smec, & - n_sil5calc,n_sil5quar, & - n_sil5feld,n_sil5hema, & - n_sil5gyps,n_sil5ilhe, & - n_sil5kahe,n_sil5smhe, & - n_sil5cahe,n_sil5quhe, & - n_sil5fehe,n_sil5gyhe/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - , & - (dryEffRadMinerals(9),i=1,ntm_sil5)& - /) - - ! -#elif defined( TRACERS_DUST_Silt4 ) - - ! Adjust if number of dust tracers changes. - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clayilli,i=1,nSubClays),( & - n_claykaol,i=1,nSubClays), & - (n_claysmec,i=1,nSubClays), & - (n_claycalc,i=1,nSubClays), & - (n_clayquar,i=1,nSubClays), & - (n_clayfeld,i=1,nSubClays), & - (n_clayhema,i=1,nSubClays), & - (n_claygyps,i=1,nSubClays), & - (n_clayilhe,i=1,nSubClays), & - (n_claykahe,i=1,nSubClays), & - (n_claysmhe,i=1,nSubClays), & - (n_claycahe,i=1,nSubClays), & - (n_clayquhe,i=1,nSubClays), & - (n_clayfehe,i=1,nSubClays), & - (n_claygyhe,i=1,nSubClays), & - n_sil1illi,n_sil1kaol, & - n_sil1smec,n_sil1calc, & - n_sil1quar,n_sil1feld, & - n_sil1hema,n_sil1gyps, & - n_sil1ilhe,n_sil1kahe, & - n_sil1smhe,n_sil1cahe, & - n_sil1quhe,n_sil1fehe, & - n_sil1gyhe,n_sil2illi, & - n_sil2kaol,n_sil2smec, & - n_sil2calc,n_sil2quar, & - n_sil2feld,n_sil2hema, & - n_sil2gyps,n_sil2ilhe, & - n_sil2kahe,n_sil2smhe, & - n_sil2cahe,n_sil2quhe, & - n_sil2fehe,n_sil2gyhe, & - n_sil3illi,n_sil3kaol, & - n_sil3smec,n_sil3calc, & - n_sil3quar,n_sil3feld, & - n_sil3hema,n_sil3gyps, & - n_sil3ilhe,n_sil3kahe, & - n_sil3smhe,n_sil3cahe, & - n_sil3quhe,n_sil3fehe, & - n_sil3gyhe,n_sil4illi, & - n_sil4kaol,n_sil4smec, & - n_sil4calc,n_sil4quar, & - n_sil4feld,n_sil4hema, & - n_sil4gyps,n_sil4ilhe, & - n_sil4kahe,n_sil4smhe, & - n_sil4cahe,n_sil4quhe, & - n_sil4fehe,n_sil4gyhe/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - , & - (dryEffRadMinerals(8),i=1,ntm_sil4)& - /) - ! -#else - - ! Adjust if number of dust tracers changes. - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clayilli,i=1,nSubClays),( & - n_claykaol,i=1,nSubClays), & - (n_claysmec,i=1,nSubClays), & - (n_claycalc,i=1,nSubClays), & - (n_clayquar,i=1,nSubClays), & - (n_clayfeld,i=1,nSubClays), & - (n_clayhema,i=1,nSubClays), & - (n_claygyps,i=1,nSubClays), & - (n_clayilhe,i=1,nSubClays), & - (n_claykahe,i=1,nSubClays), & - (n_claysmhe,i=1,nSubClays), & - (n_claycahe,i=1,nSubClays), & - (n_clayquhe,i=1,nSubClays), & - (n_clayfehe,i=1,nSubClays), & - (n_claygyhe,i=1,nSubClays), & - n_sil1illi,n_sil1kaol, & - n_sil1smec,n_sil1calc, & - n_sil1quar,n_sil1feld, & - n_sil1hema,n_sil1gyps, & - n_sil1ilhe,n_sil1kahe, & - n_sil1smhe,n_sil1cahe, & - n_sil1quhe,n_sil1fehe, & - n_sil1gyhe,n_sil2illi, & - n_sil2kaol,n_sil2smec, & - n_sil2calc,n_sil2quar, & - n_sil2feld,n_sil2hema, & - n_sil2gyps,n_sil2ilhe, & - n_sil2kahe,n_sil2smhe, & - n_sil2cahe,n_sil2quhe, & - n_sil2fehe,n_sil2gyhe, & - n_sil3illi,n_sil3kaol, & - n_sil3smec,n_sil3calc, & - n_sil3quar,n_sil3feld, & - n_sil3hema,n_sil3gyps, & - n_sil3ilhe,n_sil3kahe, & - n_sil3smhe,n_sil3cahe, & - n_sil3quhe,n_sil3fehe, & - n_sil3gyhe/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - /) - -#endif - - IF ( tracers_minerals ) CALL CALCSUBCLAYWEIGHTS - - wttr(n+1 : n+nraero_dust) = (/((SUBCLAYWEIGHTS(i,j),i=1,nSubClays& - ),j=1,ntm_clay), & - (1.D0,i=1,ntm_sil1+ntm_sil2+ntm_sil3+& - ntm_sil4+ntm_sil5)/) - - densclay = (/(TRPDENS(n_clayilli),i=1,nSubClays), & - (TRPDENS(n_claykaol),i=1,nSubClays), & - (TRPDENS(n_claysmec),i=1,nSubClays), & - (TRPDENS(n_claycalc),i=1,nSubClays), & - (TRPDENS(n_clayquar),i=1,nSubClays), & - (TRPDENS(n_clayfeld),i=1,nSubClays), & - (TRPDENS(n_clayhema),i=1,nSubClays), & - (TRPDENS(n_claygyps),i=1,nSubClays), & - (TRPDENS(n_clayilhe),i=1,nSubClays), & - (TRPDENS(n_claykahe),i=1,nSubClays), & - (TRPDENS(n_claysmhe),i=1,nSubClays), & - (TRPDENS(n_claycahe),i=1,nSubClays), & - (TRPDENS(n_clayquhe),i=1,nSubClays), & - (TRPDENS(n_clayfehe),i=1,nSubClays), & - (TRPDENS(n_claygyhe),i=1,nSubClays)/) - denssil1 = (/TRPDENS(n_sil1illi),TRPDENS(n_sil1kaol), & - TRPDENS(n_sil1smec),TRPDENS(n_sil1calc), & - TRPDENS(n_sil1quar),TRPDENS(n_sil1feld), & - TRPDENS(n_sil1hema),TRPDENS(n_sil1gyps), & - TRPDENS(n_sil1ilhe),TRPDENS(n_sil1kahe), & - TRPDENS(n_sil1smhe),TRPDENS(n_sil1cahe), & - TRPDENS(n_sil1quhe),TRPDENS(n_sil1fehe), & - TRPDENS(n_sil1gyhe)/) - denssil2 = denssil1 - denssil3 = denssil1 -#ifdef TRACERS_DUST_Silt4 - denssil4 = denssil1 -#endif /* TRACERS_DUST_Silt4 */ -#ifdef TRACERS_DUST_Silt5 - denssil5 = denssil1 -#endif /* TRACERS_DUST_Silt5 */ - - -#if defined( TRACERS_DUST_Silt4 ) & defined( TRACERS_DUST_Silt5 ) - - traden(n+1 : n+nraero_dust) = (/densclay( : ),denssil1( : ),denssil2(& - : ),denssil3( : ),denssil4( : ), & - denssil5( : )/)*1D-3 - ! Convert from kg/m^3 to g/cm^3 - -#elif defined( TRACERS_DUST_Silt5 ) - - traden(n+1 : n+nraero_dust) = (/densclay( : ),denssil1( : ),denssil2(& - : ),denssil3( : ),denssil5( : )/)*1D-3 - ! Convert from kg/m^3 to g/cm^3 - -#elif defined( TRACERS_DUST_Silt4 ) - - traden(n+1 : n+nraero_dust) = (/densclay( : ),denssil1( : ),denssil2(& - : ),denssil3( : ),denssil4( : )/)*1D-3 - ! Convert from kg/m^3 to g/cm^3 - -#else - ! - traden(n+1 : n+nraero_dust) = (/densclay( : ),denssil1( : ),denssil2(& - : ),denssil3( : )/)*1D-3 - ! Convert from kg/m^3 to g/cm^3 - -#endif - -#else /* not TRACERS_MINERALS */ - - -#if defined( TRACERS_DUST_Silt4 ) & defined( TRACERS_DUST_Silt5 ) - - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clay,i=1,nSubClays),n_silt1& - ,n_silt2,n_silt3,n_silt4, & - n_silt5/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - , & - (dryEffRadMinerals(8),i=1,ntm_sil4)& - , & - (dryEffRadMinerals(9),i=1,ntm_sil5)& - /) - -#elif defined( TRACERS_DUST_Silt5 ) - - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clay,i=1,nSubClays),n_silt1& - ,n_silt2,n_silt3,n_silt5/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - , & - (dryEffRadMinerals(9),i=1,ntm_sil5)& - /) - ! -#elif defined( TRACERS_DUST_Silt4 ) - - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clay,i=1,nSubClays),n_silt1& - ,n_silt2,n_silt3,n_silt4/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - , & - (dryEffRadMinerals(8),i=1,ntm_sil4)& - /) - ! -#else - - ntrix_aod(n+1 : n+nraero_dust) = (/(n_clay,i=1,nSubClays),n_silt1& - ,n_silt2,n_silt3/) - - trrdry(n+1 : n+nraero_dust) = (/(dryEffRadMinerals(1 : nSubClays),i& - =1,ntm_clay), & - (dryEffRadMinerals(5),i=1,ntm_sil1)& - , & - (dryEffRadMinerals(6),i=1,ntm_sil2)& - , & - (dryEffRadMinerals(7),i=1,ntm_sil3)& - /) - ! -#endif - - IF ( imDust>=4 ) CALL CALCSUBCLAYWEIGHTS - - wttr(n+1 : n+nraero_dust) = (/((SUBCLAYWEIGHTS(i,j),i=1,nSubClays& - ),j=1,ntm_clay), & - (1.D0,i=1,ntm_sil1+ntm_sil2+ntm_sil3+& - ntm_sil4+ntm_sil5)/) - - ! Particle density of dust -#if defined( TRACERS_DUST_Silt4 ) & defined( TRACERS_DUST_Silt5 ) - - traden(n+1 : n+nraero_dust) = (/(TRPDENS(n_clay),i=1,nSubClays), & - TRPDENS(n_silt1),TRPDENS(n_silt2), & - TRPDENS(n_silt3),TRPDENS(n_silt4), & - TRPDENS(n_silt5)/)*1D-3 - ! Convert from kg/m^3 to g/cm^3 - -#elif defined( TRACERS_DUST_Silt5 ) - - traden(n+1 : n+nraero_dust) = (/(TRPDENS(n_clay),i=1,nSubClays), & - TRPDENS(n_silt1),TRPDENS(n_silt2), & - TRPDENS(n_silt3),TRPDENS(n_silt5)/)& - *1D-3 ! Convert from kg/m^3 to g/cm^3 - ! -#elif defined( TRACERS_DUST_Silt4 ) - - traden(n+1 : n+nraero_dust) = (/(TRPDENS(n_clay),i=1,nSubClays), & - TRPDENS(n_silt1),TRPDENS(n_silt2), & - TRPDENS(n_silt3),TRPDENS(n_silt4)/)& - *1D-3 ! Convert from kg/m^3 to g/cm^3 - ! -#else - - traden(n+1 : n+nraero_dust) = (/(TRPDENS(n_clay),i=1,nSubClays), & - TRPDENS(n_silt1),TRPDENS(n_silt2), & - TRPDENS(n_silt3)/)*1D-3 - ! Convert from kg/m^3 to g/cm^3 - -#endif - - -#endif /* TRACERS_MINERALS */ - - itr(n+1 : n+nraero_dust) = 7 - ! all dust cases, outside ifdefs - krhtra(n+1 : n+nraero_dust) = 0 - ! no deliq for dust or minerals - fttasc(n+1 : n+nraero_dust) = 1.3D0 - ! increase dust AOD by 1.3 in LW - ENDIF - n = n + nraero_dust -#endif /* (defined TRACERS_DUST) || (defined TRACERS_MINERALS) */ - !----------------------------------------------------------------------- - !define ntrix_rf, based on the OMA tracers above - IF ( n>0 ) THEN - IF ( diag_fc==2 ) THEN - ntrix_rf(1 : nraero_OMA) = ntrix_aod(1 : nraero_OMA) - ELSEIF ( diag_fc==1 ) THEN - ntrix_rf(1) = ntrix_aod(1) - ENDIF - ENDIF - !----------------------------------------------------------------------- -#if (defined TRACERS_AMP) || (defined TRACERS_AMP_M1) - IF ( nraero_AMP>0 ) THEN - IF ( rad_interact_aer>0 ) THEN - FS8OPX(1 : 7) = 0.D0 - FT8OPX(1 : 7) = 0.D0 - ENDIF - ntrix_aod(n+1 : n+nraero_AMP) = (/n_N_AKK_1,n_N_ACC_1,n_N_DD1_1, & - n_N_DS1_1,n_N_DD2_1,n_N_DS2_1, & - n_N_SSA_1,n_N_SSC_1,n_N_OCC_1, & - n_N_BC1_1,n_N_BC2_1,n_N_BC3_1, & - n_N_DBC_1,n_N_BOC_1,n_N_BCS_1, & - n_N_MXX_1/) - IF ( diag_fc==2 ) THEN - ntrix_rf(n+1 : n+nraero_AMP) = ntrix_aod(n+1 : n+nraero_AMP) - ELSEIF ( diag_fc==1 ) THEN - ntrix_rf(n+1) = ntrix_aod(n+1) - ENDIF - ENDIF - n = n + nraero_AMP -#endif /* (defined TRACERS_AMP) || (defined TRACERS_AMP_M1) */ - !----------------------------------------------------------------------- -#ifdef TRACERS_TOMAS - IF ( nraero_TOMAS>0 ) THEN - IF ( rad_interact_aer>0 ) THEN - FS8OPX(1 : 2) = 0.D0 - FS8OPX(4 : 7) = 0.D0 - FT8OPX(1 : 2) = 0.D0 - FT8OPX(4 : 7) = 0.D0 -#ifdef TRACERS_NITRATE - FS8OPX(3) = 0.D0 - FT8OPX(3) = 0.D0 -#endif /* TRACERS_NITRATE */ - ENDIF - - ntrix_aod(n+1 : n+nraero_TOMAS) & - = (/N_ASO4(1),N_ANACL(1),N_AECOB(1),N_AECIL(1),N_AOCOB(1), & - N_AOCIL(1),N_ADUST(1)/) - itr(n+1 : n+nraero_TOMAS) = (/1,2,6,5,4,4,7/) - krhtra(n+1 : n+nraero_TOMAS) = 0 - ! ANUM(1) for internal-mixing case. Others(ncomp-1) for external-mixing case. - IF ( diag_fc==2 ) THEN - ntrix_rf(n+1 : n+nraero_TOMAS) = ntrix_aod(n+1 : n+nraero_TOMAS) - ELSEIF ( diag_fc==1 ) THEN - ntrix_rf(n+1) = ntrix_aod(n+1) - ENDIF - ENDIF - n = n + nraero_TOMAS -#endif - !======================================================================= - !======================================================================= -#endif /* TRACERS_ON */ - - ! set default FSTOPX and FTTOPX values - IF ( rad_interact_aer>0 ) THEN - FSTOPX( : ) = 1.D0 - FTTOPX( : ) = 1.D0 - ELSE - FSTOPX( : ) = 0.D0 - FTTOPX( : ) = 0.D0 - ENDIF - skip_AOD_in_rad = rad_interact_aer>0 - - IF ( ktrend/=0 ) THEN - !**** Read in time history of well-mixed greenhouse gases - CALL OPENUNIT('GHG',iu,.FALSE.,.TRUE.) - CALL GHGHST(iu) - CALL CLOSEUNIT(iu) - IF ( FILE_EXISTS('dH2O') .AND. H2ObyCH4/=0. .AND. Kradia<=0 ) & - THEN - !**** Read in dH2O : H2O prod.rate in kg/m^2 per day and ppm_CH4 - CALL OPENUNIT('dH2O',iu,.FALSE.,.TRUE.) -#if defined(CUBED_SPHERE) - CALL READ_QMA(iu,plbx) -#else - CALL GETQMA(iu,lat_dg,plbx,dh2o,lm,jm) -#endif - CALL CLOSEUNIT(iu) - ELSE - H2ObyCH4 = 0. - ENDIF - ENDIF -#ifdef OLD_BCdalbsn - IF ( dalbsnX/=0. ) THEN - CALL UPDBCD(1990) - depoBC_1990 = depoBC - ENDIF -#endif - !**** set up unit numbers for 14 more radiation input files - donotread = -9999 - nrfun( : ) = 0 ! green light - nrfun(12 : 13) = donotread ! not used in GCM - nrfun(10 : 11) = donotread ! obsolete O3 data - nrfun(6) = donotread ! dust read externally now - IF ( .NOT.transmission_corrections ) nrfun(4) = donotread - IF ( madvol==0 ) nrfun(7) = donotread - IF ( madeps==0 ) nrfun(8) = donotread - ! if(ksolar < 0) nrfun(9) = donotread - nrfun(9) = donotread ! open/read RADN9 inside RCOMP1 - DO IU = 1, 14 - IF ( nrfun(iu)==donotread ) CYCLE - CALL OPENUNIT(RUNSTR(IU),NRFUN(IU),QBIN(IU),.TRUE.) - ENDDO - - LS1_loc = 1 - ! default - !*********************************************************************** - ! Main Radiative Initializations - ! ------------------------------------------------------------------ - CALL RCOMP1(NRFUN) - IF ( AM_I_ROOT() ) CALL WRITER(6,0) - ! print rad. control parameters - !*********************************************************************** - DO IU = 1, 14 - IF ( nrfun(iu)==donotread ) CYCLE - CALL CLOSEUNIT(NRFUN(IU)) - ENDDO - !**** Save initial (currently permanent and global) Q in rad.layers - DO LR = 1, LM_REQ - SHL0(LR) = SHL(LM+LR) - ENDDO - WRITE (out_line,*) 'spec.hum in rad.equ.layers : ', SHL0 - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - -#ifdef ALTER_RADF_BY_LAT - !**** Save initial rad forcing alterations : - FS8OPX_orig( : ) = FS8OPX( : ) - FT8OPX_orig( : ) = FT8OPX( : ) ! aerosols - - !**** Read in the factors used for alterations : - CALL OPENUNIT('ALT_GHG_LAT',iu2,.FALSE.,.TRUE.) - READ (iu2,*) - ! skip first line - DO n = 1, 46 - READ (iu2,'(a6,13D8.3)') skip, (FULGAS_lat(nn,n),nn=1,13) - ENDDO - CALL CLOSEUNIT(iu2) - CALL OPENUNIT('ALT_AER_LAT',iu2,.FALSE.,.TRUE.) - READ (iu2,*) - ! skip first line - DO n = 1, 46 - READ (iu2,'(a6,8D8.3)') skip, (FS8OPX_lat(nn,n),nn=1,8) - ENDDO - READ (iu2,*) - ! skip first line - DO n = 1, 46 - READ (iu2,'(a6,8D8.3)') skip, (FT8OPX_lat(nn,n),nn=1,8) - ENDDO - CALL CLOSEUNIT(iu2) -#endif - - ! transplanted from main(). needs reviving - ! USE RAD_COM, only : dimrad_sv - ! CHARACTER aDATE*14 - ! if (Kradia.ne.0 .and. Kradia<10) then - ! write(aDATE(1 : 7),'(a3,I4.4)') aMON(1 : 3),Jyear - ! if (Kradia.gt.0) aDATE(4 : 7)=' ' - ! call openunit(trim('RAD'//aDATE(1 : 7)),iu_RAD,.true.,.false.) - ! if (Kradia.lt.0) call io_POS(iu_RAD,Itime-1,2*dimrad_sv,Nrad) - ! end if - - IF ( rad_scm ) THEN - IF ( FILE_EXISTS('GASES') ) THEN - ! GAS NUMBER 1 2 3 4 5 6 7 - ! H2O CO2 O3 O2 NO2 N2O CH4 - ! GAS NUMBER 8 9 10 11 12 13 - ! CCL3F1 CCL2F2 N2 CFC-Y CFC-Z SO2 - - gasnames = (/ 'h2o ','co2 ','o3 ','o2 ','no2 ', & - 'n2o ','ch4 ','cfc11 ','cfc12 ','n2 ', & - 'cfc-y ','cfc-z ','so2 ' /) - set_gases_internally = .FALSE. - u0gas = 0. - fid = PAR_OPEN(grid,'GASES','read') - DO igas = 1, SIZE(gasnames) - CALL READ_DATA(grid,fid,TRIM(gasnames(igas)), & - u0gas(1:LM, igas)) - u0gas(lm+1 : ,igas) = u0gas(lm,igas) - ! fill lm+1:LM+lm_req - IF ( TRIM(gasnames(igas))=='h2o' ) q(1,1, : ) & - = u0gas(1:LM, igas)*(mwat/mair) ! vol. ratio -> sp. hum. - u0gas( : ,igas) = AML00*u0gas( : ,igas) & - *((1D5/mair)*(gasc*tf/101325D0)) - ! vol. ratio -> cm-atm - ENDDO - CALL PAR_CLOSE(grid,fid) - - !fulgas = 1. ! needed? - - ulgas = u0gas - - ! Multiply gas amounts by rundeck scaling factors. - ! Looping not an option since fulgas array does not yet - ! contain the factors. - - !ulgas( : , 1) = ulgas( : , 1)*H2OstratX - ulgas( : ,2) = ulgas( : ,2)*CO2X - ulgas( : ,3) = ulgas( : ,3)*O3X - ulgas( : ,4) = ulgas( : ,4)*O2X - ulgas( : ,5) = ulgas( : ,5)*NO2X - ulgas( : ,6) = ulgas( : ,6)*N2OX - ulgas( : ,7) = ulgas( : ,7)*CH4X - ulgas( : ,8) = ulgas( : ,8)*CFC11X - ulgas( : ,9) = ulgas( : ,9)*CFC12X - ulgas( : ,10) = ulgas( : ,10)*N2CX - ulgas( : ,11) = ulgas( : ,11)*XGHGX - ulgas( : ,12) = ulgas( : ,12)*YGHGX - ulgas( : ,13) = ulgas( : ,13)*SO2X - - ENDIF - IF ( FILE_EXISTS('VISAODangstr') ) THEN - set_aerosols_internally = .FALSE. - ! fid = par_open(grid,'VISAODangstr','read') - ! not needed for initial CIRC cases which have zero aerosol - ! todo : read optical depths and scale with Angstrom exponent - ! weighted by solar flux - ! .... - ! call par_close(grid,fid) - sraext = 0. - srasct = 0. - sragcb = 0. - srdext = 0. - srdsct = 0. - srdgcb = 0. - srvext = 0. - srvsct = 0. - srvgcb = 0. - srbext = 0. - srbsct = 0. - srbgcb = 0. - traalk = 0. - trdalk = 0. - trvalk = 0. - trbalk = 0. - ENDIF - i = 1 - j = 1 - DO l = 1, lm - tloc = t(i,j,l)*pk(l,i,j) - IF ( tloc>=tf ) THEN - SVLHX(l,i,j) = lhe - ELSE - SVLHX(l,i,j) = lhs - ENDIF - SVLAT(l,i,j) = SVLHX(l,i,j) - RHSAV(l,i,j) = q(i,j,l)/QSAT(tloc,SVLHX(l,i,j),PMID(l,i,j)) - ENDDO - !llow=1; lmid=2; lhi=3 - ENDIF - -END SUBROUTINE INIT_RAD - -SUBROUTINE SETATM ! dummy routine in gcm -END SUBROUTINE SETATM - -SUBROUTINE GETVEG(LONR,LATR) ! dummy routine in gcm - INTEGER LONR, LATR -END SUBROUTINE GETVEG - -SUBROUTINE DAILY_RAD(end_of_day) - !@sum daily_RAD sets radiation parameters that change every day - !@auth G. Schmidt - !@calls RADPAR : RCOMPT - USE DOMAIN_DECOMP_ATM, ONLY : AM_I_ROOT - USE DOMAIN_DECOMP_ATM, ONLY : GRID, GETDOMAINBOUNDS - USE MODEL_COM, ONLY : MODELECLOCK - USE RADPAR, ONLY : FULGAS, JYEARR => JYEAR, JDAYR => JDAY, XREF, & - KYEARV -#ifdef ALTER_RADF_BY_LAT - USE RADPAR, ONLY : FULGAS_orig -#endif - USE RADPAR, ONLY : RCOMPT, WRITET - USE RAD_COM, ONLY : co2x, n2ox, ch4x, cfc11x, cfc12x, xGHGx, & - h2ostratx, o2x, no2x, n2cx, yghgx, so2x, o3x, o3_yr, ghg_yr, & - co2ppm, Volc_yr, albsn_yr, dalbsnX, SNOAGE, snoage_def, & - chl_from_seawifs - USE DIAG_COM, ONLY : iwrite, jwrite, itwrite, TDIURN - USE GEOM, ONLY : IMAXJ - IMPLICIT NONE - LOGICAL, INTENT(IN) :: end_of_day - INTEGER :: year, dayOfYear - INTEGER :: i, j, i_0, i_1, j_0, j_1, itype - - CALL MODELECLOCK%GET(year=year,dayOfYear=dayOfYear) - - !**** Update time dependent radiative parameters each day - ! Get black carbon deposition data for the appropriate year - ! (does nothing except at a restart or the beginning of a new year) - IF ( dalbsnX/=0. ) THEN - IF ( albsn_yr==0 ) THEN -#ifdef OLD_BCdalbsn - CALL UPDBCD(year) -#else - CALL UPDBCDALBSN(year,dayofyear) -#endif - ELSE -#ifdef OLD_BCdalbsn - CALL UPDBCD(albsn_yr) -#else - ! as per radiation-code convention, pass -albsn_yr to indicate - ! perpetual-year mode - CALL UPDBCDALBSN(-albsn_yr,dayofyear) -#endif - ENDIF - ENDIF - ! Hack : 2 specific volc. eruption scenarios for 2000-2100 period - IF ( volc_yr==-2010 ) THEN ! repeat some old volcanos - KYEARV = YEAR - IF ( YEAR>2010 ) KYEARV = YEAR - 100 - ! go back 100 years - ENDIF - IF ( volc_yr==-2000 ) THEN - KYEARV = YEAR - IF ( YEAR>2000 ) KYEARV = YEAR - 50 - ! go back 50 years til 2050 - IF ( YEAR>2050 ) KYEARV = YEAR - 150 - ! then go back 150 years - ENDIF - - JDAYR = dayOfYear - JYEARR = YEAR - CALL RCOMPT - ! FULGAS(2 : ) is set only in the first call to RCOMPT unless ghg_yr=0 - ! Optional scaling of the observed value only in case it was (re)set - IF ( .NOT.end_of_day .AND. H2OstratX>=0. ) FULGAS(1) = FULGAS(1) & - *H2OstratX - IF ( .NOT.end_of_day .OR. O3_yr==0. ) FULGAS(3) = FULGAS(3)*O3X - IF ( ghg_yr==0 .OR. .NOT.end_of_day ) THEN - FULGAS(2) = FULGAS(2)*CO2X - FULGAS(6) = FULGAS(6)*N2OX - FULGAS(7) = FULGAS(7)*CH4X - FULGAS(8) = FULGAS(8)*CFC11X - FULGAS(9) = FULGAS(9)*CFC12X - FULGAS(11) = FULGAS(11)*XGHGX - FULGAS(12) = FULGAS(12)*YGHGX - ENDIF - IF ( .NOT.end_of_day ) THEN - FULGAS(4) = FULGAS(4)*O2X - FULGAS(5) = FULGAS(5)*NO2X - FULGAS(10) = FULGAS(10)*N2CX - FULGAS(13) = FULGAS(13)*SO2X - ! no effect since FULGAS(13)=0. - ENDIF - - !**** write trend table for forcing 'itwrite' for years iwrite->jwrite - !**** itwrite : 1-2=GHG 3=So 4-5=O3 6-9=aerosols : Trop,DesDust,Volc,Total - IF ( AM_I_ROOT() .AND. jwrite>1500 ) & - CALL WRITET(6,itwrite,iwrite,jwrite,1,0) - -#ifdef ALTER_RADF_BY_LAT - !**** Save initial rad forcing alterations : - FULGAS_orig( : ) = FULGAS( : ) - ! GHGs -#endif - - !**** Define CO2 (ppm) for rest of model - co2ppm = FULGAS(2)*XREF(1) - - IF ( chl_from_seawifs>0 ) CALL GET_CHL_FROM_SEAWIFS - - IF ( end_of_day ) THEN - - CALL GETDOMAINBOUNDS(grid,J_STRT=J_0,J_STOP=J_1) - CALL GETDOMAINBOUNDS(grid,I_STRT=I_0,I_STOP=I_1) - - DO j = J_0, J_1 - DO i = I_0, IMAXJ(j) - !**** - !**** increase snow age depending on snoage_def - !**** - IF ( snoage_def==0 ) THEN - ! update indep. of ts - DO itype = 1, 3 - SNOAGE(itype,i,j) = 1. + .98D0*SNOAGE(itype,i,j) - ENDDO - ELSEIF ( snoage_def==1 ) THEN - ! update if max T>0 - IF ( TDIURN(i,j,7)>0 ) SNOAGE(1,i,j) & - = 1. + .98D0*SNOAGE(1,i,j) - ! ocean ice (not currently used) - IF ( TDIURN(i,j,8)>0 ) SNOAGE(2,i,j) & - = 1. + .98D0*SNOAGE(2,i,j) - ! land ice - IF ( TDIURN(i,j,2)>0 ) SNOAGE(3,i,j) & - = 1. + .98D0*SNOAGE(3,i,j) - ! land - ELSE - WRITE (6,*) "This snoage_def is not defined : ", & - snoage_def - WRITE (6,*) "Please use : 0 (update indep of T)" - WRITE (6,*) " 1 (update if T>0)" - CALL STOP_MODEL('stopped in RAD_DRV.f',255) - ENDIF - ENDDO - ENDDO - ENDIF - -END SUBROUTINE DAILY_RAD - -SUBROUTINE GET_CHL_FROM_SEAWIFS - - USE DOMAIN_DECOMP_ATM, ONLY : GRID, REWIND_PARALLEL, READT_PARALLEL,& - GETDOMAINBOUNDS - USE FLUXES, ONLY : FOCEAN, atmocn - USE CONSTANT, ONLY : by12 - USE MODEL_COM, ONLY : MODELECLOCK, calendar - USE RESOLUTION, ONLY : im, jm - USE FILEMANAGER, ONLY : NAMEUNIT - USE GEOM, ONLY : IMAXJ - USE FILEMANAGER, ONLY : OPENUNIT - USE CALENDARMONTH_MOD - IMPLICIT NONE - - REAL*8 :: TEMP_LOCAL(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,2) - INTEGER :: month, date, year - LOGICAL :: HAVE_NORTH_POLE, HAVE_SOUTH_POLE - INTEGER :: LSTMON, I, J, J_0, J_1, I_0, I_1 - INTEGER, SAVE :: IMON0 = 0 - INTEGER, SAVE :: iu_chl = -1 - !@var ACHL,ECHL1,ECHL0,BCHL,CCHL arrays for the reading in chlorophyll - REAL*8, ALLOCATABLE, DIMENSION( : , : ), SAVE :: ACHL, ECHL1, ECHL0,& - BCHL, CCHL - REAL*8 :: TIME - INTEGER :: I_0H, I_1H, J_0H, J_1H - TYPE (CALENDARMONTH) :: cMonth - - I_0H = grid%I_STRT_HALO - I_1H = grid%I_STOP_HALO - J_0H = grid%J_STRT_HALO - J_1H = grid%J_STOP_HALO - IF ( iu_chl<0 ) THEN - CALL OPENUNIT("CHL_DATA",iu_CHL,.TRUE.,.TRUE.) - ALLOCATE (ACHL(I_0H : I_1H,J_0H : J_1H),ECHL1(I_0H : I_1H,J_0H : J_1H),& - ECHL0(I_0H : I_1H,J_0H : J_1H),BCHL(I_0H : I_1H,J_0H : J_1H),& - CCHL(I_0H : I_1H,J_0H : J_1H)) - ENDIF - CALL MODELECLOCK%GET(month=month,date=date) - CALL GETDOMAINBOUNDS(GRID,J_STRT=J_0,J_STOP=J_1, & - HAVE_SOUTH_POLE=HAVE_SOUTH_POLE, & - HAVE_NORTH_POLE=HAVE_NORTH_POLE) - I_0 = grid%I_STRT - I_1 = grid%I_STOP - - !**** Read in Seawifs files here - IF ( month/=IMON0 ) THEN - IF ( IMON0==0 ) THEN - !**** READ IN LAST MONTH''S END-OF-MONTH DATA - LSTMON = month - 1 - IF ( lstmon==0 ) lstmon = 12 - CALL READT_PARALLEL(grid,iu_CHL,NAMEUNIT(iu_CHL),TEMP_LOCAL,& - LSTMON) - ECHL0 = TEMP_LOCAL( : , : ,2) - ELSE - !**** COPY END-OF-OLD-MONTH DATA TO START-OF-NEW-MONTH DATA - ECHL0 = ECHL1 - ENDIF - !**** READ IN CURRENT MONTHS DATA : MEAN AND END-OF-MONTH - IMON0 = month - IF ( month==1 ) CALL REWIND_PARALLEL(iu_CHL) - CALL READT_PARALLEL(grid,iu_CHL,NAMEUNIT(iu_CHL),TEMP_LOCAL,1) - ACHL = TEMP_LOCAL( : , : ,1) - ECHL1 = TEMP_LOCAL( : , : ,2) - - !**** FIND INTERPOLATION COEFFICIENTS (LINEAR/QUADRATIC FIT) - DO J = J_0, J_1 - DO I = I_0, IMAXJ(J) - BCHL(I,J) = ECHL1(I,J) - ECHL0(I,J) - CCHL(I,J) = 3.*(ECHL1(I,J)+ECHL0(I,J)) - 6.*ACHL(I,J) - ENDDO - ENDDO - ENDIF - !**** Calculate CHL for current day - cMonth = calendar%GETCALENDARMONTH(month,year) - TIME = (DATE-.5)/cMonth%DAYSINMONTH - .5 - ! -.50 ) THEN - !**** CHL always uses quadratic fit - atmocn%CHL(I,J) = ACHL(I,J) + BCHL(I,J)*TIME + CCHL(I,J) & - *(TIME**2-BY12) - IF ( atmocn%CHL(I,J)<0 ) atmocn%CHL(I,J) = 0. - ! just in case - ENDIF - ENDDO - ENDDO - !**** REPLICATE VALUES AT POLE - IF ( HAVE_NORTH_POLE ) THEN - IF ( FOCEAN(1,JM)>0 ) atmocn%CHL(2 : IM,JM) = atmocn%CHL(1,JM) - ENDIF - IF ( HAVE_SOUTH_POLE ) THEN - IF ( FOCEAN(1,1)>0 ) atmocn%CHL(2 : IM,1) = atmocn%CHL(1,1) - ENDIF - atmocn%CHL_DEFINED = .TRUE. - -END SUBROUTINE GET_CHL_FROM_SEAWIFS - -SUBROUTINE DAILY_ORBIT(end_of_day) - !@sum DAILY performs daily tasks at end-of-day and maybe at (re)starts - !@auth Original Development Team - !@calls constant : orbit - USE MODEL_COM, ONLY : MODELECLOCK - USE RAD_COM, ONLY : RSDIST, COSD, SIND, COSZ_day, SUNSET, & - VARIABLE_ORB_PAR, ORB_PAR_YEAR_BP, USEORBIT => ORBIT - USE DOMAIN_DECOMP_ATM, ONLY : AM_I_ROOT - USE RAD_COSZ0, ONLY : DAILY_COSZ - USE BASETIME_MOD - USE TIMEINTERVAL_MOD - USE RATIONAL_MOD - IMPLICIT NONE - REAL*8 :: SUNLON, SUNLAT, LAM, EDPY, VEDAY, PYEAR - LOGICAL, INTENT(IN) :: end_of_day - INTEGER :: year, dayOfYear - TYPE (BASETIME) :: t - REAL*8 :: declinationAngle - TYPE (TIMEINTERVAL) :: halfDay - - CALL MODELECLOCK%GET(year=year,dayOfYear=dayOfYear) - - !**** CALCULATE SOLAR ANGLES AND ORBIT POSITION - !**** This is for noon (GMT) for new day. - - !**** The orbital calculation will need to vary depending on the kind - !**** of calendar adopted (i.e. a generic 365 day year, or a transient - !**** calendar including leap years etc.). For transient calendars the - !**** dayOfYear passed to orbit needs to be adjusted to represent the number - !**** of days from Jan 1 2000AD. - ! EDPY=365.2425d0, VEDAY=79.3125d0 ! YR 2000AD - ! dayOfYear => dayOfYear + 365 * (YEAR-2000) + appropriate number of leaps - !**** Default calculation (no leap, VE=Mar 21 hr 0) - ! EDPY=365d0 ; VEDAY=79d0 ! Generic year - !**** PMIP calculation (no leap, VE=Mar 21 hr 12) - EDPY = 365D0 - VEDAY = 79.5D0 ! Generic year - !**** Update orbital parameters at start of year - IF ( dayOfYear==1 ) CALL USEORBIT%SETYEAR(REAL(year,KIND=8)) - - ! Use time for the _middle_ of the day to compute - ! zenith angle : - - halfDay = TIMEINTERVAL(USEORBIT%GETMEANDAY()/2) - t = NEWBASETIME(MODELECLOCK%GETTIMEATBEGINNINGOFCURRENTDAY() & - +halfDay) - - sinD = USEORBIT%GETSINDECLINATIONANGLE(t) - cosD = SQRT(1-sinD**2) - rsdist = USEORBIT%GETDISTANCE(t)**2 - - CALL DAILY_COSZ(sind,cosd,cosz_day,sunset) - -END SUBROUTINE DAILY_ORBIT - -SUBROUTINE DAILY_CH4OX(end_of_day) - !@sum DAILY performs daily tasks at end-of-day and maybe at (re)starts - !@vers 2013/03/27 - !@auth Original Development Team - !@calls constant : orbit - USE RESOLUTION, ONLY : im, jm, lm - USE ATM_COM, ONLY : Q - USE MODEL_COM, ONLY : MODELECLOCK - USE MODEL_COM, ONLY : itime - USE GEOM, ONLY : AXYP, IMAXJ, LAT2D - USE ATM_COM, ONLY : BYMA - USE RADPAR, ONLY : GHGAM, ghgyr2, ghgyr1 - USE RAD_COM, ONLY : DH2O, H2ObyCH4, ghg_yr -#ifdef TRACERS_WATER - USE OLDTRACER_MOD, ONLY : TR_WD_TYPE, NWATER, TR_H2OBYCH4, ITIME_TR0 - USE TRACER_COM, ONLY : TRM, NTM -#endif - USE DIAG_COM, ONLY : FTYPE, ntype, AIJ => AIJ_LOC - USE DIAG_COM_RAD, ONLY : j_h2och4, ij_h2och4 - USE DOMAIN_DECOMP_ATM, ONLY : grid, GETDOMAINBOUNDS, AM_I_ROOT - IMPLICIT NONE - REAL*8 :: xCH4, xdH2O - INTEGER i, j, l, iy, it - LOGICAL, INTENT(IN) :: end_of_day -#ifdef TRACERS_WATER - INTEGER n -#endif - !**** Extract domain decomposition info - INTEGER :: J_0, J_1, I_0, I_1 - LOGICAL :: HAVE_SOUTH_POLE, HAVE_NORTH_POLE - INTEGER :: year, month - - CALL MODELECLOCK%GET(year=year,month=month) - - CALL GETDOMAINBOUNDS(grid,J_STRT=J_0,J_STOP=J_1, & - HAVE_SOUTH_POLE=HAVE_SOUTH_POLE, & - HAVE_NORTH_POLE=HAVE_NORTH_POLE) - I_0 = grid%I_STRT - I_1 = grid%I_STOP - - IF ( .NOT.end_of_day ) RETURN - - !**** Tasks to be done at end of day only - IF ( H2ObyCH4>0 ) THEN - !**** Add obs. H2O generated by CH4(*H2ObyCH4) using a 2 year lag - iy = year - 2 - ghgyr1 + 1 - IF ( ghg_yr>0 ) iy = ghg_yr - 2 - ghgyr1 + 1 - IF ( iy<1 ) iy = 1 - IF ( iy>ghgyr2-ghgyr1+1 ) iy = ghgyr2 - ghgyr1 + 1 - xCH4 = GHGAM(3,iy)*H2ObyCH4 - ! If (AM_I_ROOT()) - ! write(6,*) 'add in stratosphere : H2O gen. by CH4(ppm)=',xCH4 - - DO l = 1, lm - DO j = J_0, J_1 - DO i = I_0, IMAXJ(j) -#ifdef CUBED_SPHERE - CALL LAT_INTERP_QMA(LAT2D(i,j),l,month,xdH2O) -#else - xdH2O = DH2O(j,l,month) -#endif - Q(i,j,l) = Q(i,j,l) + xCH4*xdH2O*BYMA(l,i,j) -#ifdef TRACERS_WATER - !**** Add water to relevant tracers as well - DO n = 1, ntm - IF ( ITIME_TR0(n)<=itime ) THEN - SELECT CASE (TR_WD_TYPE(n)) - CASE (NWATER) - ! water : add CH4-sourced water to tracers - TRM(i,j,l,n) = TRM(i,j,l,n) + TR_H2OBYCH4(n) & - *xCH4*xdH2O*AXYP(i,j) - ENDSELECT - ENDIF - ENDDO -#endif - DO it = 1, ntype - CALL INC_AJ(i,j,it,j_h2och4, & - xCH4*xdH2O*FTYPE(it,i,j)) - ENDDO - AIJ(i,j,ij_h2och4) = AIJ(i,j,ij_h2och4) + xCH4*xdH2O - ENDDO - ENDDO - IF ( HAVE_NORTH_POLE ) Q(2 : im,jm,l) = Q(1,jm,l) - IF ( HAVE_SOUTH_POLE ) Q(2 : im,1,l) = Q(1,1,l) -#ifdef TRACERS_WATER - DO n = 1, ntm - IF ( HAVE_SOUTH_POLE ) TRM(2 : im,1,l,n) = TRM(1,1,l,n) - IF ( HAVE_NORTH_POLE ) TRM(2 : im,jm,l,n) = TRM(1,jm,l,n) - ENDDO -#endif - ENDDO - ENDIF - -END SUBROUTINE DAILY_CH4OX - -SUBROUTINE RADIA - !@sum RADIA adds the radiation heating to the temperatures - !@vers 2013/03/27 - !@auth Original Development Team - !@calls tropwmo,coszs,coszt, RADPAR : rcompx ! writer,writet - USE CONSTANT, ONLY : lhe, lhs, twopi, tf, stbo, rhow, mair, grav, & - bysha, pi, radian, areag - USE RESOLUTION, ONLY : pmtop - USE RESOLUTION, ONLY : im, jm, lm -#ifdef TRACERS_SPECIAL_Shindell - USE RESOLUTION, ONLY : LS1 => LS1_NOMINAL -#endif - USE ATM_COM, ONLY : kradia, lm_req, p, t, Q, iu_rad, req_fac_d - USE MODEL_COM - USE TIMECONSTANTS_MOD, ONLY : SECONDS_PER_DAY, INT_DAYS_PER_YEAR - USE ATM_COM, ONLY : BYAML00 - USE GEOM, ONLY : IMAXJ, AXYP, BYAXYP, LAT2D, LON2D - ! for threadprivate copyin common block - ! INPUT DATA ! not (i,j) dependent - USE RADPAR, ONLY : LX, tauwc0, tauic0, WRITER, RCOMPX, UPDGHG, & - S00WM2, RATLS0, S0, JYEARR => JYEAR, JDAYR => JDAY, FULGAS, & - use_tracer_chem, FS8OPX, FT8OPX, use_o3_ref, KYEARG, KJDAYG, & - planck_tmin, planck_tmax - ! set in radpar block data -#ifdef ALTER_RADF_BY_LAT - USE RADPAR, ONLY : FS8OPX_orig, FT8OPX_orig, FULGAS_orig -#endif - ! INPUT DATA (i,j) dependent - USE RADPAR, ONLY : JLAT46 => JLAT, ILON72 => ILON, JGCM, IGCM, L1, & - LMR => NL, PLB, TLB, TLM, SHL, RHL, ltopcl, TAUWC, TAUIC, & - SIZEWC, SIZEIC, kdeliq, POCEAN, PEARTH, POICE, PLICE, PLAKE, & - COSZ, PVT, TGO, TGE, TGOI, TGLI, TSL, WMAG, WEARTH, AGESN, & - SNOWD, SNOWOI, SNOWLI, dALBsn, ZSNWOI, ZOICE, zmp, fmp, flags,& - LS1_loc, snow_frac, zlake, TRACER, FSTOPX, FTTOPX, chem_IN, & - nraero_aod => NTRACE, FTAUC, LOC_CHL, FSTASC, FTTASC -#ifdef HEALY_LM_DIAGS - USE RADPAR, ONLY : VTAULAT -#endif -#ifdef GCC_COUPLE_RAD - USE RADPAR, ONLY : GCCco2_IN, use_tracer_GCCco2, GCCCO2_OUT -#endif - - ! OUTPUT DATA - USE RADPAR, ONLY : TRDFLB, TRNFLB, TRUFLB, TRFCRL, chem_out, SRDFLB,& - SRNFLB, SRUFLB, SRFHRL, PLAVIS, PLANIR, ALBVIS, ALBNIR, & - FSRNFG, SRRVIS, SRRNIR, SRAVIS, SRANIR, SRXVIS, SRDVIS, & - BTEMPW, SRAEXT, SRASCT, SRAGCB, SRDEXT, SRDSCT, SRDGCB, & - SRVEXT, SRVSCT, SRVGCB, aesqex, aesqsc, aesqcb, CO2outCol, & - aesqex_dry, aesqsc_dry, aesqcb_dry, SRXNIR, SRDNIR - USE RAD_COM, ONLY : modrd, nrad - USE RAD_COM, ONLY : rqt, SRHR, TRHR, FSF, COSZ1, s0x, rsdist, & - nradfrc, CH4X_RADoverCHEM, snoage, PLB0, SHL0, TCHG, ALB, & - FSRDIR, SRVISSURF, SRDN, cfrac, RCLD, chem_tracer_save, & - rad_interact_aer, kliq, RHfix, CLDx, GHG_YR, CO2X, N2OX, CH4X,& - CFC11X, CFC12X, XGHGX, rad_forc_lev, NTRIX_AOD, NTRIX_RF, & - WTTR, cloud_rad_forc, CC_cdncx, OD_cdncx, cdncl, dALBsnX, & - rad_to_chem, TRSURF, DIRVIS, FSRDIF, DIRNIR, DIFNIR, & - aer_rad_forc, clim_interact_chem, TAUSUMW, TAUSUMI, & - TAero_aod_diag, chl_from_obio, chl_from_seawifs -#ifdef GCC_COUPLE_RAD - USE RAD_COM, ONLY : GCCCO2_TRACER_SAVE, GCCCO2RAD_TO_CHEM -#endif -#ifdef GCAP - USE RAD_COM, ONLY : TAUW3D, TAUI3D -#endif -#ifdef mjo_subdd - USE RAD_COM, ONLY : SWHR, LWHR, SWHR_cnt, LWHR_cnt, OLR_ACC, & - OLR_cnt, SWU_AVG, swu_cnt -#endif -#ifdef ALTER_RADF_BY_LAT - USE RAD_COM, ONLY : FULGAS_lat, FS8OPX_lat, FT8OPX_lat -#endif -#ifdef TRACERS_DUST - USE RAD_COM, ONLY : srnflb_save, trnflb_save -#endif -#if (defined SHINDELL_STRAT_EXTRA) &(defined ACCMIP_LIKE_DIAGS) - USE RAD_COM, ONLY : STRATO3_TRACER_SAVE -#endif -#ifdef TRACERS_ON - USE RAD_COM, ONLY : tau_as, tau_cs, tau_dry, nraero_rf -#ifdef CACHED_SUBDD - USE CONSTANT, ONLY : grav, Rgas - USE RAD_COM, ONLY : abstau_as, abstau_cs, abstau_dry, swfrc, lwfrc - USE RUNTIMECONTROLS_MOD, ONLY : tracers_amp, tracers_tomas -#endif /* CACHED_SUBDD */ -#endif - USE RANDOM - USE CLOUDS_COM, ONLY : TAUSS, TAUMC, SVLHX, RHSAV, SVLAT, CLDSAV, & - CLDMC, CLDSS, CSIZMC, CSIZSS, llow, lmid, lhi, FSS, TAUSSIP, & - CSIZSSIP, QLSS, QISS, QLMC, QIMC, GET_CLD_OVERLAP - ! subroutine -#ifdef GCAP - USE CLOUDS_COM, ONLY : CLDSS3D - USE CONSTANT, ONLY : teeny -#endif - USE DIAG_COM, ONLY : ia_rad, JREG, AIJ => AIJ_LOC, AIJL => AIJL_LOC,& - ntype, FTYPE, itocean, itlake, itearth, itlandi, itoice, & - itlkice, ADIURN => ADIURN_LOC, ndiuvar, ia_rad_frc -#ifdef USE_HDIURN - USE DIAG_COM, ONLY : HDIURN => HDIURN_LOC -#endif - USE DIAG_COM, ONLY : iwrite, jwrite, itwrite, ndiupt, IJDD, AFLX_ST,& - hr_in_day, hr_in_month - USE DIAG_COM_RAD -#ifdef TRACERS_ON - USE DIAG_COM, ONLY : adiurn_dust, SAVE3DAOD - USE RAD_COM, ONLY : diag_fc -#endif - USE ATM_COM, ONLY : PK, PEDN, PMID, PDSIG, ltropo, MA, BYMA - USE SEAICE_COM, ONLY : si_atm - USE GHY_COM, ONLY : FEARTH, snowd_ij => snowd - USE ENT_COM, ONLY : ENTCELLS - USE ENT_MOD, ONLY : ENT_GET_EXPORTS, N_COVERTYPES - !YKIM-temp hack - USE ENT_DRV, ONLY : MAP_ENT2GISS !YKIM-temp hack - USE LAKES_COM, ONLY : flake, dlake !,mwl - USE FLUXES, ONLY : ASFLX4, atmocn, atmice, atmgla, atmlnd, atmsrf, & - FLICE, FLAND, FOCEAN - USE DOMAIN_DECOMP_ATM, ONLY : grid, WRITE_PARALLEL - USE DOMAIN_DECOMP_ATM, ONLY : GLOBALSUM, GETDOMAINBOUNDS - USE RAD_COSZ0, ONLY : COSZT, COSZS - -#ifdef TRACERS_ON - USE OLDTRACER_MOD, ONLY : TRNAME, TRPDENS - USE TRACER_COM, ONLY : NTM, n_Ox, TRM, n_OCB, n_BCII, n_BCIA, & - n_OCIA, N_OCII, N_SO4_D2, N_SO4_D3, N_SO4, n_stratOx, & - N_N_AKK_1 -#ifdef TRACERS_NITRATE - USE OLDTRACER_MOD, ONLY : TR_MM - USE TRACER_COM, ONLY : n_NH4, n_NO3p -#endif -#ifdef TRACERS_AEROSOLS_SOA - USE TRACER_COM, ONLY : n_isopp1a, n_isopp2a -#ifdef TRACERS_TERP - USE TRACER_COM, ONLY : n_apinp1a, n_apinp2a -#endif /* TRACERS_TERP */ -#endif /* TRACERS_AEROSOLS_SOA */ -#ifdef TRACERS_AEROSOLS_OCEAN - USE TRACER_COM, ONLY : n_ococean -#endif /* TRACERS_AEROSOLS_OCEAN */ -#ifdef GCC_COUPLE_RAD - USE TRACER_COM, ONLY : n_CO2n - USE CONSTANT, ONLY : avog - USE OLDTRACER_MOD, ONLY : TR_MM -#endif -#ifdef TRACERS_AEROSOLS_VBS - USE TRACERS_VBS, ONLY : vbs_tr -#endif - USE TRDIAG_COM, ONLY : TAIJS => TAIJS_LOC, taijls => TAIJLS_LOC, & - IJTS_FC, IJTS_TAU, IJTS_TAUSUB, IJTS_FCSUB, IJLT_3DTAU, & - IJLT_3DAAOD, IJLT_3DTAUCS, IJLT_3DAAODCS, IJLT_3DTAUDRY, & - IJLT_3DAAODDRY, IJTS_SQEX, IJTS_SQEXSUB, IJTS_SQSC, & - IJTS_SQSCSUB, IJTS_SQCB, IJTS_SQCBSUB, diag_rad, diag_aod_3d, & - save_dry_aod -#ifdef AUXILIARY_OX_RADF - USE TRDIAG_COM, ONLY : IJTS_AUXFC -#endif /* AUXILIARY_OX_RADF */ -#ifdef BC_ALB - USE TRDIAG_COM, ONLY : IJTS_ALB, ijts_sunlit_snow -#endif /* BC_ALB */ -#ifdef TRACERS_SPECIAL_Shindell - USE TRCHEM_SHINDELL_COM, ONLY : Lmax_rad_O3, Lmax_rad_CH4 -#endif /* TRACERS_SPECIAL_Shindell */ -#ifdef TRACERS_TOMAS - USE TOMAS_AEROSOL, ONLY : icomp -#endif -#endif /* TRACERS_ON */ - USE AERPARAM_MOD, ONLY : DCDNC_EST -#ifdef OLD_BCdalbsn - USE AERPARAM_MOD, ONLY : DEPOBC, DEPOBC_1990 -#else - USE AERPARAM_MOD, ONLY : BCDALBSN -#endif - USE TIMERPACKAGE_MOD, ONLY : STARTTIMER => START, STOPTIMER => STOP - USE DICTIONARY_MOD, ONLY : GET_PARAM, IS_SET_PARAM -#ifdef CACHED_SUBDD - USE SUBDD_MOD, ONLY : sched_rad, SUBDD_GROUPS, SUBDD_TYPE, & - subdd_ngroups, INC_SUBDD, FIND_GROUPS, lmaxsubdd -#endif -#ifdef SCM - USE SCM_COM, ONLY : SCMopt, SCMin - USE CONSTANT, ONLY : SHA - USE ATM_COM, ONLY : QCL -#endif - USE DIAG_COM, ONLY : IJ_NINTAEREXT, IJ_NINTAERSCA, IJ_NINTAERASY - USE RADPAR, ONLY : nintaerext, nintaersca, nintaerasy - -#ifdef GCAP - USE RAD_COM, ONLY : SAVE_ALB, save_cosz2 - USE O3MOD, ONLY : SAVE_TO3 -#endif -#ifdef TRACERS_GC - USE CHEM_COM, ONLY : TrM, i_O3, i_CH4 - USE DICTIONARY_MOD, ONLY : SYNC_PARAM - USE DOMAIN_DECOMP_ATM, ONLY : AM_I_ROOT - USE RAD_COM, ONLY : SAVE_RF, SAVE_RF_TP, SAVE_RF_3D -#endif - - IMPLICIT NONE - REAL*8 dz, rho - ! - !@var wtrtau,icetau per-layer opacity for cloud water,ice - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,lm) & - :: wtrtau, icetau -#ifdef SCM - REAL*8 q_above(LM+1), q_below(LM+1), Frad(LM+1) -#endif - ! INPUT DATA partly (i,j) dependent, partly global - REAL*8 U0GAS, taulim -#ifdef OLD_BCdalbsn - REAL*8 xdalbs, sumda, tauda, fsnow - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: sumda_psum, tauda_psum -#endif - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: COSZ2, & - COSZA, TRINCG, BTMPW, WSOIL, fmp_com - REAL*8, DIMENSION(4,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: SNFS, TNFS - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: SNFSCRF,& - TNFSCRF, SNFSCRF2, TNFSCRF2, LWDNCS, & - SNFS_AS_noA, TNFS_AS_noA, SNFS_CS_noA, & - TNFS_CS_noA, SWUS, CTT, CTP, WTRCLD, ICECLD - REAL*8, DIMENSION(18,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: SNFSAERRF, TNFSAERRF -#ifdef CFMIP3_SUBDD - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: swut, & - swutcs, cfmip_twp, swdcls, swucls, swdt - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,lm) & - :: cfmip_cf, cfmip_qci, cfmip_qcl -#endif -#ifdef CACHED_SUBDD - INTEGER :: igrp, ngroups, grpids(subdd_ngroups) - TYPE (SUBDD_TYPE), POINTER :: subdd - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: SDDARR - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,lm) & - :: SDDARR3D -#ifdef TRACERS_ON - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,nraero_rf) & - :: sddarr3drf - INTEGER :: f -#endif /* TRACERS_ON */ -#ifdef SCM - ! radiative flux profiles for sub-daily output, generalized - ! for GCM grid but currently limited to SCM use - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,lm) & - :: TRDFLB_prof, TRUFLB_prof, SRDFLB_prof, & - SRUFLB_prof -#endif -#ifdef TRACERS_ON - ! types of aods to be saved - ! The name will be any combination of {,TRNAME}{as,cs}{,a}aod - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,lm,nraero_aod)& - :: sddarr4d - CHARACTER(LEN=10), DIMENSION(2) & - :: sgroups = (/'taijh ','taijlh'/) - CHARACTER(LEN=10), DIMENSION(3) :: ssky = (/'as ','cs ','dry'/) - CHARACTER(LEN=10), DIMENSION(2) :: sabs = (/' ','a'/) - CHARACTER(LEN=10), DIMENSION(2) :: sfrc = (/'swf','lwf'/) - CHARACTER(LEN=10) :: spcname - CHARACTER(LEN=50) :: sname - INTEGER :: g, s, a -#endif /* TRACERS_ON */ - !@var CO2out for holding 3D CO2 from rad code for SUBDD - REAL*8, DIMENSION(LM,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: CO2out -#endif /* CACHED_SUBDD */ -#if (defined ACCMIP_LIKE_DIAGS) -#ifndef SKIP_ACCMIP_GHG_RADF_DIAGS - !@var snfs_ghg,tnfs_ghg like SNFS/TNFS but with reference GHG for - !@+ radiative forcing calculations. TOA only. - !@+ index 1=CH4, 2=N2O, 3=CFC11, 4=CFC12 - REAL*8, DIMENSION(4,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: snfs_ghg, tnfs_ghg - REAL*8, DIMENSION(4) :: sv_fulgas_ref, sv_fulgas_now - INTEGER :: nf, GFrefY, GFrefD, GFnowY, GFnowD - !@var nfghg fulgas( ) index of radf diag ghgs : - INTEGER, DIMENSION(4) :: nfghg = (/7,6,8,9/) -#endif -#endif - -#if defined ( TRACERS_GC ) - !@var snfs_ghg,tnfs_ghg like SNFS/TNFS but with reference GHG for - !@+ radiative forcing calculations. TOA only. - !@+ index 1=CH4, 2=N2O, 3=CFC11, 4=CFC12 - REAL*8, DIMENSION(4,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: snfs_ghg, tnfs_ghg, & - snfs_ghg_tp, tnfs_ghg_tp - - REAL*8, DIMENSION(4) :: sv_fulgas_ref, sv_fulgas_now - INTEGER :: nf, GFrefY, GFrefD, GFnowY, GFnowD - !@var nfghg fulgas( ) index of radf diag ghgs : - INTEGER, DIMENSION(4) :: nfghg = (/7,6,8,9/) - ! For ozone - REAL*8, DIMENSION(5,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: SNFST_o3ref, TNFST_o3ref - ! For 3D fluxes - ! 20 radiatively-active species (1:13 gases + 12:20 aerosol particle types + 21:21 clouds) - REAL*8, DIMENSION( grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO, & - LM+LM_REQ+1, 21 ) :: SNFS_3D_pert, TNFS_3D_pert - ! Baseline 3-D radiation fluxes - REAL*8, DIMENSION( grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO, & - LM+LM_REQ+1 ) :: SNFS_3D, TNFS_3D - - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO,LM+LM_REQ+1) & - :: SDDARRFLX -#endif - - ! variables for running uncoupled concentration-driven GCC -#ifdef GCC_UNCOUPLE_RAD_CONCEN - REAL*8 :: GCCco2_fulgas_ref, GCCco2_fulgas_now - INTEGER :: GCCco2nowY, GCCco2nowD -#endif - -#ifdef HEALY_LM_DIAGS - ! GHG Effective forcing relative to 1850 - REAL*8 :: ghg_totforc, CO2I = 285.2, N2OI = .2754, CH4I = .791 - ! 1850 GHG's - REAL*8 :: CO2R = 337.9, N2OR = .3012, CH4R = 1.547 ! RAD's 1979 Reference values - REAL*8 :: FCO2, FN2O, FCH4 ! Current Model GHG - REAL*8 :: FE - !! Function -#endif -#ifdef TRACERS_ON - !@var SNFST,TNFST like SNFS/TNFS but with/without specific tracers for - !@+ radiative forcing calculations - REAL*8, DIMENSION(2,nraero_rf,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: SNFST, & - TNFST - !@var SNFST_o3ref,TNFST_o3ref like snfst,tnfst for special case ozone for - !@+ which nraero_rf fields are not defined. Indicies are : - !@+ 1=LTROPO,reference, 2=TOA,reference; not saving surface forcing. - !@+ 3=LTROPO or LS1-1,auxiliary, 4=TOA,auxiliary; 5=LS1-1,reference -#if (defined SHINDELL_STRAT_EXTRA) &(defined ACCMIP_LIKE_DIAGS) - REAL*8, DIMENSION(5,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: SNFST_o3ref, TNFST_o3ref, snfst_stratOx, & - tnfst_stratOx -#endif /* SHINDELL_STRAT_EXTRA &ACCMIP_LIKE_DIAGS */ -#ifdef BC_ALB - REAL*8, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: ALBNBC, & - NFSNBC, dALBsnBC - ! not to be confused with BCdalbsn from an input file - LOGICAL, DIMENSION(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) & - :: bc_snow_present -#endif /* BC_ALB */ -#endif /* TRACERS_ON */ - REAL*8, DIMENSION(LM_REQ,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: TRHRS, & - SRHRS - REAL*8, DIMENSION(0 : LM+LM_REQ,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) :: TRHRA, & - SRHRA - ! for adj.frc - REAL*8, DIMENSION(LM) :: TOTCLD, SS_CLD, dcc_cdncl, dod_cdncl - INTEGER I, J, L, K, KR, LR, JR, IH, IHM, INCH, JK, IT, iy, iend, & - N, onoff_aer, onoff_chem, LFRC, JTIME, n1, moddrf - REAL*8 ROT1, ROT2, PLAND, CSS, CMC, DEPTH, QSS, TAUSSL, TAUSSLIP, & - TAUMCL, ELHX, CLDCV, X, OPNSKY, CSZ2, tauup, taudn, & - ptype4(4), taucl, wtlin, MSTRAT, STRATQ, STRJ, MSTJ, optdw,& - optdi, rsign_aer, rsign_chem, tauex5, tauex6, tausct, & - taugcb, dcdnc, & - QR(LM,grid%I_STRT_HALO:grid%I_STOP_HALO,grid%J_STRT_HALO : & - grid%J_STOP_HALO), & - CLDinfo(LM,3,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) - REAL*8 tmpS(8), tmpT(8) - REAL*8 QSAT -#ifdef BC_ALB - REAL*8 dALBsn1 -#endif - LOGICAL set_clayilli, set_claykaol, set_claysmec, set_claycalc, & - set_clayquar - ! - REAL*8 RDSS(LM,grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO), & - RDMC(grid%I_STRT_HALO:grid%I_STOP_HALO, & - grid%J_STRT_HALO:grid%J_STOP_HALO) - - REAL*8 :: TMP(NDIUVAR) - INTEGER, PARAMETER :: NLOC_DIU_VAR = 8 - INTEGER :: idx(NLOC_DIU_VAR) -#if (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - INTEGER, PARAMETER :: NLOC_DIU_VARB = 5 -#else - INTEGER, PARAMETER :: NLOC_DIU_VARB = 3 -#endif - INTEGER :: idxb(NLOC_DIU_VARB) - - INTEGER :: aj_alb_inds(8) - REAL*8, DIMENSION(lm_req) :: bydpreq - - ! INTEGER ICKERR,JCKERR,KCKERR - INTEGER :: J_0, J_1, I_0, I_1 - INTEGER :: J_0S, J_1S - LOGICAL :: HAVE_SOUTH_POLE, HAVE_NORTH_POLE - CHARACTER(LEN=300) :: out_line - - INTEGER :: NIJ_BEFORE_J0, NIJ_AFTER_J1, NIJ_AFTER_I1 - INTEGER :: initial_GHG_setup - - REAL*8 :: PVT0(N_COVERTYPES), HVT0(N_COVERTYPES) -#ifdef TRACERS_NITRATE - REAL*8 :: nh4_on_no3 -#endif -#ifdef TRACERS_TOMAS - REAL*8 :: qcb_col(6,ICOMP-2), qcb_col_dry(6,ICOMP-2) -#endif - - REAL*8, DIMENSION( : , : ), POINTER :: RSI, ZSI, SNOWI, POND_MELT - LOGICAL, DIMENSION( : , : ), POINTER :: FLAG_DSWS - REAL*8 :: rhodz - ! air density times layer thickness (kg/m2 - INTEGER :: year, dayOfYear, hour, date - -#ifdef TRACERS_ON - !@var nsub_ntrix array of index counters for sub classes of tracers - INTEGER, DIMENSION(ntm) :: nsub_ntrix -#endif - -#ifdef GCC_COUPLE_RAD - INTEGER :: Lmax_rad_CO2 = LM -#endif - - CALL MODELECLOCK%GET(year=year,dayOfYear=dayOfYear,hour=hour, & - date=date) - - RSI => SI_ATM%RSI - ZSI => SI_ATM%ZSI - SNOWI => SI_ATM%SNOWI - POND_MELT => SI_ATM%POND_MELT - FLAG_DSWS => SI_ATM%FLAG_DSWS - - ! - !**** - CALL STARTTIMER('RADIA()') - - idx = (/(IDD_CL7+i-1,i=1,7),IDD_CCV/) -#if (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - idxb = (/IDD_PALB,IDD_GALB,IDD_ABSA,idd_aot,idd_aot2/) -#else - idxb = (/IDD_PALB,IDD_GALB,IDD_ABSA/) -#endif - CALL GETDOMAINBOUNDS(grid,HAVE_SOUTH_POLE=HAVE_SOUTH_POLE, & - HAVE_NORTH_POLE=HAVE_NORTH_POLE) - I_0 = grid%I_STRT - I_1 = grid%I_STOP - J_0 = grid%J_STRT - J_1 = grid%J_STOP - J_0S = grid%J_STRT_SKP - J_1S = grid%J_STOP_SKP - - - !**** - !**** FLAND LAND COVERAGE (1) - !**** FLICE LAND ICE COVERAGE (1) - !**** - !**** GTEMPR RADIATIVE TEMPERATURE ARRAY OVER ALL SURFACE TYPES (K) - !**** RSI RATIO OF OCEAN ICE COVERAGE TO WATER COVERAGE (1) - !**** - !**** VDATA 1-11 RATIOS FOR THE 11 VEGETATION TYPES (1) - !**** - - !**** limit optical cloud depth from below : taulim - taulim = MIN(tauwc0,tauic0) - ! currently both .001 - tauwc0 = taulim - tauic0 = taulim - !**** Calculate mean cosine of zenith angle for the current physics step - JTIME = MOD(ITIME,NDAY) - ROT1 = (TWOPI*JTIME)/NDAY - ! ROT2=ROT1+TWOPI*DTsrc/SECONDS_PER_DAY - ! CALL COSZT (ROT1,ROT2,COSZ1) - CALL CALC_ZENITH_ANGLE ! moved to main loop - - IF ( kradia>0 ) THEN ! read in all rad. input data (frc.runs) - iend = 1 - it = itime - 1 ! make sure, at least 1 record is read - DO WHILE ( MOD(itime-it,NDAY*INT_DAYS_PER_YEAR)/=0 ) - !**** input data : WARNINGS - !**** 1 - any changes here also go in later (look for 'iu_rad') - !**** 2 - keep "dimrad_sv" up-to-date : dimrad_sv=IM*JM*{ - ! LM+LM_REQ+1+ - ! * ,(((GTEMPR(k,i,j),k=1,4),i=1,im),j=1,jm) ! (4+) - ! LM+1+3*LM+1+1+ - ! 1+1+1+1+1+ - ! 3+1+.5+.5+ - !**** output data : really needed only if kradia=2 - ! 2+1+1 - !**** total : dimrad_sv= IM*JM*(7*LM + 3*LM_REQ + 24 (+4)) => RAD_COM.f - READ (iu_rad,END=10,ERR=10) it, T, RQT, atmsrf%TSAVG, QR, P,& - CLDinfo, rsi, zsi, wsoil, & - atmsrf%WSAVG, snowi, & - atmgla%SNOW, atmlnd%SNOWE, & - snoage, fmp_com, flag_dsws, & - ltropo, atmlnd%FR_SNOW_RAD, & - dlake, flake, srhra, trhra, iy - ! 2(LM+LM_REQ+1)} - IF ( qcheck ) THEN - WRITE (out_line,*) 'reading RADfile at Itime', Itime, it,& - iy - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - ENDIF - ENDDO - iend = 0 -10 IF ( it/=iy .OR. iend==1 ) THEN - WRITE (out_line,*) 'RAD input file bad or too short : ', & - itime, it, iy, iend - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - CALL STOP_MODEL('RADIA : input file bad or too short',255) - ENDIF - ENDIF - - IF ( MODRD==0 ) THEN - IDACC(ia_rad) = IDACC(ia_rad) + 1 - moddrf = 1 - ! skip rad.forcing diags if nradfrc.le.0 - IF ( nradfrc>0 ) moddrf = MOD(itime-itimei,nrad*nradfrc) - !**** - IF ( moddrf==0 ) IDACC(ia_rad_frc) = IDACC(ia_rad_frc) + 1 - !**** Interface with radiation routines, done only every NRAD time steps - !**** - !**** Calculate mean cosine of zenith angle for the full radiation step - ROT2 = ROT1 + TWOPI*NRAD*DTsrc/SECONDS_PER_DAY - CALL COSZS(ROT1,ROT2,COSZ2,COSZA) -#ifdef GCAP - save_COSZ2 = COSZ2 -#endif - JDAYR = dayOfYear - JYEARR = YEAR - - IF ( IS_SET_PARAM('s0') ) THEN - ! typically only used for SCM - CALL GET_PARAM('s0',s0) - s00wm2 = s0 - ! just in case - ELSE - S0 = S0X*S00WM2*RATLS0/RSDIST - ENDIF - -#ifdef OLD_BCdalbsn - !**** find scaling factors for surface albedo reduction - ! LTM : Fix, testing equality of reals is not reliable - IF ( dalbsnX/=0 ) THEN - IF ( HAVE_SOUTH_POLE ) THEN - sumda_psum( : ,1) = AXYP(1,1) - tauda_psum( : ,1) = AXYP(1,1)*DEPOBC_1990(1,1) - ENDIF - DO j = J_0S, J_1S - DO i = I_0, I_1 - ! ilon72, jlat46 are indices w.r.t 72x46 grid - ! JLAT46=INT(1.+(J-1.)*0.25*DLAT_DG+.5) ! slightly more general - ! ILON72=INT(.5+(I-.5)*72./IM+.5) - ilon72 = 1 + INT(72D0*LON2D(i,j)/twopi) - jlat46 = 1 + INT(45D0*(LAT2D(i,j)+92D0*radian)/pi) - fsnow = FLICE(i,j) + rsi(i,j)*(1-FLAND(i,j)) - IF ( atmlnd%SNOWE(I,J)>0. ) fsnow = fsnow + & - FEARTH(i,j) - sumda_psum(i,j) = AXYP(i,j)*fsnow - tauda_psum(i,j) = AXYP(i,j)*fsnow*DEPOBC_1990(i,j) - ENDDO - ENDDO - IF ( HAVE_NORTH_POLE ) THEN - sumda_psum( : ,JM) = AXYP(1,jm)*rsi(1,jm) - tauda_psum( : ,JM) = AXYP(1,jm)*rsi(1,jm)*DEPOBC_1990(1,jm) - ENDIF - CALL GLOBALSUM(grid,sumda_psum,sumda,ALL=.TRUE.) - CALL GLOBALSUM(grid,tauda_psum,tauda,ALL=.TRUE.) - - xdalbs = -dalbsnX*sumda/tauda - IF ( QCHECK ) WRITE (6,*) 'coeff. for snow alb reduction', & - xdalbs - ENDIF - ! dalbsnX not zero -#endif - - IF ( kradia<=0 ) THEN - IF ( QCHECK ) THEN - !**** Calculate mean strat water conc - STRATQ = 0. - MSTRAT = 0. - DO J = J_0, J_1 - STRJ = 0. - MSTJ = 0. - DO I = I_0, IMAXJ(J) - DO L = LTROPO(I,J) + 1, LM - STRJ = STRJ + Q(I,J,L)*MA(L,I,J)*AXYP(I,J) - MSTJ = MSTJ + MA(L,I,J)*AXYP(I,J) - ENDDO - ENDDO - IF ( J==1 .OR. J==JM ) THEN - STRJ = STRJ*IM - MSTJ = MSTJ*IM - ENDIF - STRATQ = STRATQ + STRJ - MSTRAT = MSTRAT + MSTJ - ENDDO - PRINT *, "Strat water vapour (ppmv), mass (mb)", & - 1D6*STRATQ*mair/(18.*MSTRAT), & - PMTOP + 1D-2*GRAV*MSTRAT/AREAG - ENDIF - - !**** Get the random numbers outside openMP parallel regions - !**** but keep MC calculation separate from SS clouds - !**** To get parallel consistency also with mpi, force each process - !**** to generate random numbers for all latitudes (using BURN_RANDOM) - - !**** MC clouds are considered as a block for each I,J grid point - - CALL BURN_RANDOM(NIJ_BEFORE_J0(J_0)) - - DO J = J_0, J_1 ! complete overlap - CALL BURN_RANDOM((I_0-1)) - DO I = I_0, IMAXJ(J) - RDMC(I,J) = RANDU(X) - ! 1 random number per column - ENDDO - CALL BURN_RANDOM(NIJ_AFTER_I1(I_1)) - ENDDO - - CALL BURN_RANDOM((NIJ_AFTER_J1(J_1))) - - !**** SS clouds are considered as a block for each continuous cloud - CALL BURN_RANDOM(NIJ_BEFORE_J0(j_0)*LM) - - DO J = J_0, J_1 ! semi-random overlap - CALL BURN_RANDOM((I_0-1)*LM) - DO I = I_0, IMAXJ(J) - ! reverse loop kept only for consistency with previous version - DO L = LM, 1, -1 - ! better : 1,LM - IF ( TAUSS(L,I,J)<=taulim ) CLDSS(L,I,J) = 0. - IF ( TAUMC(L,I,J)<=taulim ) CLDMC(L,I,J) = 0. - RDSS(L,I,J) = RANDU(X) - ENDDO - ENDDO - CALL BURN_RANDOM(NIJ_AFTER_I1(I_1)*LM) - ENDDO - - CALL BURN_RANDOM(NIJ_AFTER_J1(j_1)*LM) - - ENDIF ! kradia le 0 - -#if (defined ACCMIP_LIKE_DIAGS) -#ifndef SKIP_ACCMIP_GHG_RADF_DIAGS - ! because of additional updghg calls, these factors will not apply : - ! LTM : This needs to be fixed, testing equality of reals is not reliable - IF ( CO2X/=1. ) CALL STOP_MODEL('CO2x.ne.1 accmip diags',255) - IF ( N2OX/=1. ) CALL STOP_MODEL('N2Ox.ne.1 accmip diags',255) - IF ( CH4X/=1. ) CALL STOP_MODEL('CH4x.ne.1 accmip diags',255) - IF ( CFC11X/=1. ) CALL STOP_MODEL('CFC11x.ne.1 accmip diags', & - 255) - IF ( CFC12X/=1. ) CALL STOP_MODEL('CFC12x.ne.1 accmip diags', & - 255) - IF ( XGHGX/=1. ) CALL STOP_MODEL('XGHGx.ne.1 accmip diags',255) - GFrefY = 1850 - GFrefD = 182 ! ghg forcing refrnce year, day - GFnowY = JyearR - GFnowD = JdayR ! ghg current desired year, day - IF ( KJDAYG>0 ) GFnowD = KJDAYG - ! unless presribed in deck - IF ( KYEARG>0 ) GFnowY = KYEARG - ! - CALL UPDGHG(GFrefY,GFrefD) - sv_fulgas_ref(1:4) = FULGAS(nfghg(1:4)) - CALL UPDGHG(GFnowY,GFnowD) - sv_fulgas_now(1:4) = FULGAS(nfghg(1:4)) -#endif -#endif - -#if defined ( TRACERS_GC ) - - ! because of additional updghg calls, these factors will not apply : - ! LTM : This needs to be fixed, testing equality of reals is not reliable - IF ( CO2X/=1. ) CALL STOP_MODEL('CO2x.ne.1 accmip diags',255) - IF ( N2OX/=1. ) CALL STOP_MODEL('N2Ox.ne.1 accmip diags',255) - IF ( CH4X/=1. ) CALL STOP_MODEL('CH4x.ne.1 accmip diags',255) - IF ( CFC11X/=1. ) CALL STOP_MODEL('CFC11x.ne.1 accmip diags', & - 255) - IF ( CFC12X/=1. ) CALL STOP_MODEL('CFC12x.ne.1 accmip diags', & - 255) - IF ( XGHGX/=1. ) CALL STOP_MODEL('XGHGx.ne.1 accmip diags',255) - GFrefY = 1850 - GFrefD = 182 ! ghg forcing refrnce year, day - GFnowY = JyearR - GFnowD = JdayR ! ghg current desired year, day - IF ( KJDAYG>0 ) GFnowD = KJDAYG - ! unless presribed in deck - IF ( KYEARG>0 ) GFnowY = KYEARG - ! - - CALL UPDGHG(GFrefY,GFrefD) - sv_fulgas_ref(1:4) = FULGAS(nfghg(1:4)) - - CALL UPDGHG(GFnowY,GFnowD) - sv_fulgas_now(1:4) = FULGAS(nfghg(1:4)) - -#endif - - - - ! Set variables used in storing reference CO2 for uncoupled runs -#ifdef GCC_UNCOUPLE_RAD_CONCEN - IF ( KJDAYG>0 ) GCCco2nowD = KJDAYG - ! unless presribed in deck - IF ( KYEARG>0 ) GCCco2nowY = KYEARG - ! - CALL UPDGHG(1850,182) - GCCco2_fulgas_ref = FULGAS(2) - CALL UPDGHG(GCCco2nowD,GCCco2nowD) - GCCco2_fulgas_now = FULGAS(2) -#endif - -#ifdef HEALY_LM_DIAGS - FCO2 = FULGAS(2)*CO2R - FN2O = FULGAS(6)*N2OR - FCH4 = FULGAS(7)*CH4R - ! - ! write(6,*) 'RJH : GHG : CONC=', - ! * FCO2,FN2O,FCH4 - ghg_totforc = 5.35D0*LOG(FCO2/CO2I) & - + 0.036D0*(SQRT(FCH4)-SQRT(CH4I)) & - - (FE(FCH4,N2OI)-FE(CH4I,N2OI)) & - + 0.12D0*(SQRT(FN2O)-SQRT(N2OI)) & - - (FE(CH4I,FN2O)-FE(CH4I,N2OI)) - ! write(6,*) 'RJH : GHG : FORC=',ghg_totforc -#endif - - aj_alb_inds = (/J_PLAVIS,J_PLANIR,J_ALBVIS,J_ALBNIR,J_SRRVIS, & - J_SRRNIR,J_SRAVIS,J_SRANIR/) - - cfrac = 0. - wtrcld = 0. - icecld = 0. - tausumw = 0. - tausumi = 0. - ctp = 0. - ctt = 0. - swus = 0. - wtrtau = 0. - icetau = 0. -#ifdef CFMIP3_SUBDD - swut = 0. - swutcs = 0. - cfmip_twp = 0. - swdcls = 0. - swucls = 0. - swdt = 0. - cfmip_cf = 0. - cfmip_qci = 0. - cfmip_qcl = 0. -#endif -#ifdef GCAP - tauw3d = 0. - taui3d = 0. -#endif -#ifdef TRACERS_GC - save_rf = 0. - save_rf_tp = 0. - save_rf_3D = 0. - SNFS_3D_pert = 0. - TNFS_3D_pert = 0. - SNFS_3D = 0. - TNFS_3D = 0. -#endif - - !**** - !**** MAIN J LOOP - !**** - DO J = J_0, J_1 - - ! ICKERR=0 - ! JCKERR=0 - ! KCKERR=0 - - !**** - !**** MAIN I LOOP - !**** - DO I = I_0, IMAXJ(J) - !**** Radiation input files use a 72x46 grid independent of IM and JM - !**** (ilon72,jlat46) is the 4x5 box containing the center of box (i,j) - ! JLAT46=INT(1.+(J-1.)*45./(JM-1.)+.5) ! lat_index w.r.to 72x46 grid - ! JLAT46=INT(1.+(J-1.)*0.25*DLAT_DG+.5) ! slightly more general - ! ILON72=INT(.5+(I-.5)*72./IM+.5) ! lon_index w.r.to 72x46 grid - igcm = i - jgcm = j - ilon72 = 1 + INT(72D0*LON2D(i,j)/twopi) - jlat46 = 1 + INT(45D0*(LAT2D(i,j)+92D0*radian)/pi) -#ifdef ALTER_RADF_BY_LAT - FULGAS( : ) = FULGAS_orig( : )*FULGAS_lat( : ,JLAT46) - FS8OPX( : ) = FS8OPX_orig( : )*FS8OPX_lat( : ,JLAT46) - FT8OPX( : ) = FT8OPX_orig( : )*FT8OPX_lat( : ,JLAT46) -#endif - L1 = 1 ! lowest layer above ground - LMR = LM + LM_REQ ! radiation allows var. # of layers - JR = JREG(I,J) - !**** DETERMINE FRACTIONS FOR SURFACE TYPES AND COLUMN PRESSURE - PLAND = FLAND(I,J) - POICE = RSI(I,J)*(1.-PLAND) - POCEAN = (1.-PLAND) - POICE - PLAKE = FLAKE(I,J) - PLICE = FLICE(I,J) - PEARTH = FEARTH(I,J) - ptype4(1) = pocean - ! open ocean and open lake - ptype4(2) = poice - ! ocean/lake ice - ptype4(3) = plice - ! glacial ice - ptype4(4) = pearth - ! non glacial ice covered soil - - !**** CHECK SURFACE TEMPERATURES - DO IT = 1, 4 - IF ( ptype4(IT)>0. ) THEN - !CC STOP 'In Radia : Grnd Temp out of range' - ! ICKERR=ICKERR+1 - IF ( INT(ASFLX4(it)%GTEMPR(I,J))=planck_tmax ) & - WRITE (6,*) 'In Radia : Time,I,J,IT,TG1', & - ITime, I, J, IT, ASFLX4(it) & - %GTEMPR(I,J) - ENDIF - ENDDO - - !**** Set Chlorophyll concentration - IF ( POCEAN>0 ) THEN - IF ( (chl_from_seawifs>0 .OR. chl_from_obio>0) .AND. & - atmocn%CHL_DEFINED ) THEN - LOC_CHL = atmocn%CHL(I,J) - IF ( ij_chl>0 ) AIJ(I,J,IJ_CHL) = AIJ(I,J,IJ_CHL) & - + atmocn%CHL(I,J)*FOCEAN(I,J) - ! write(*,'(a,3i5,e12.4)')'RAD_DRV : ', - ! . itime,i,j,chl(i,j) - ELSE - LOC_CHL = -1.D30 - ENDIF - ENDIF - - LS1_loc = LTROPO(I,J) + 1 - ! define stratosphere for radiation - !**** kradia>1 : adjusted forcing, i.e. T adjusts in L=LS1_loc->LM+3 - IF ( kradia>1 ) LS1_loc = LS1_loc + 2 - kradia - ! favorite : kradia=3 - IF ( kradia>3 ) LS1_loc = 1 ! favorite : kradia=3 - kdeliq = 0 - ! initialize mainly for L>LM - IF ( kradia>0 ) THEN - ! rad forcing model - DO l = 1, lm - TLM(l) = T(i,j,l)*PK(l,i,j) - SHL(l) = QR(l,i,j) - IF ( SHL(l)<0 ) SHL(l) = 0 - TAUWC(l) = cldx*CLDinfo(l,1,i,j) - TAUIC(l) = cldx*CLDinfo(l,2,i,j) - SIZEWC(L) = CLDinfo(l,3,i,j) - SIZEIC(L) = SIZEWC(L) - ENDDO - ELSE ! full model - !**** - !**** DETERMINE CLOUDS (AND THEIR OPTICAL DEPTHS) SEEN BY RADIATION - !**** - CSS = 0. - CMC = 0. - CLDCV = 0. - DEPTH = 0. - OPTDW = 0. - OPTDI = 0. - ! LTM : Fix, testing equality of reals is not reliable. - IF ( cc_cdncx/=0. .OR. od_cdncx/=0. ) THEN - CALL DCDNC_EST(i,j,pland,dCDNC) - ELSE - dCDNC = 0. - ENDIF - dCC_CDNCL = CC_cdncx*dCDNC*CDNCL - dOD_CDNCL = OD_cdncx*dCDNC*CDNCL - - !**** Adjust RDSS for semi-random overlap - CALL GET_CLD_OVERLAP(lm,CLDSS( : ,i,j), & - RANDSS=rdss( : ,i,j)) - - DO L = 1, LM - IF ( Q(i,j,l)<0 ) THEN - WRITE (6,*) 'In Radia : Time,I,J,L,Q<0', ITime, & - I, J, L, Q, '->0' - Q(I,J,L) = 0. - ENDIF - QSS = Q(I,J,L)/(RHSAV(L,I,J)+1.D-20) - SHL(L) = QSS - IF ( FSS(L,I,J)*CLDSAV(L,I,J)<1. ) SHL(L) & - = (Q(I,J,L)-QSS*FSS(L,I,J)*CLDSAV(L,I,J)) & - /(1.-FSS(L,I,J)*CLDSAV(L,I,J)) - TLM(L) = T(I,J,L)*PK(L,I,J) - rhodz = PDSIG(l,i,j)*100/grav - TAUSSL = 0. - TAUSSLIP = 0. - TAUMCL = 0. - TAUWC(L) = 0. - TAUIC(L) = 0. - SIZEWC(L) = 0. - SIZEIC(L) = 0. - TOTCLD(L) = 0. - SS_CLD(L) = 0. - !**** Determine large scale and moist convective cloud cover for radia - IF ( CLDSS(L,I,J)*(1.+dcc_cdncl(l))>RDSS(L,I,J) ) & - THEN - TAUSSL = TAUSS(L,I,J)*(1.+dod_cdncl(l)) - ! tausslip is tau of ice precip in a supercooled water cloud - TAUSSLIP = TAUSSIP(L,I,J)*(1.+dod_cdncl(l)) - SHL(L) = QSS - CSS = 1. - CALL INC_AJL(i,j,l,jl_sscld,css) -#ifdef CFMIP3_SUBDD - ! LS Cloud - cfmip_cf(i,j,l) = cfmip_cf(i,j,l) + 1. -#endif - ENDIF - IF ( CLDMC(L,I,J)>RDMC(I,J) ) THEN - CMC = 1. - CALL INC_AJL(i,j,l,jl_mccld,cmc) -#ifdef CFMIP3_SUBDD - ! MC Cloud - cfmip_cf(i,j,l) = MIN(cfmip_cf(i,j,l)+1.,1.) -#endif - DEPTH = DEPTH + PDSIG(L,I,J) - IF ( TAUMC(L,I,J)>TAUSSL+TAUSSLIP ) THEN - TAUMCL = TAUMC(L,I,J) - ELHX = LHE - IF ( TLM(L)<=TF ) ELHX = LHS - SHL(L) = QSAT(TLM(L),ELHX,PMID(L,I,J)) - ENDIF - ENDIF - IF ( TAUSSL+TAUSSLIP+TAUMCL>0. ) THEN - CLDCV = 1. - TOTCLD(L) = 1. - CALL INC_AJL(i,j,l,jl_totcld,1D0) - !**** save 3D cloud fraction as seen by radiation - IF ( cldx>0 ) AIJL(I,J,L,IJL_CF) & - = AIJL(I,J,L,IJL_CF) + 1. - IF ( TAUMCL>TAUSSL+TAUSSLIP ) THEN - SIZEWC(L) = CSIZMC(L,I,J) - SIZEIC(L) = CSIZMC(L,I,J) - IF ( SVLAT(L,I,J)==LHE ) THEN - TAUWC(L) = cldx*TAUMCL - OPTDW = OPTDW + TAUWC(L) -#ifdef GCAP - TAUW3D(I,J,L) = TAUW3D(I,J,L) + TAUMCL - ! in-cloud vs. in-cell TAUWC(L) -#endif - CALL INC_AJL(i,j,l,jl_wcld,1D0) - CALL INC_AJL(i,j,l,jl_wcldwt,PDSIG(l,i,j)) - AIJ(i,j,ij_lwprad) = AIJ(i,j,ij_lwprad) & - + QLMC(l,i,j)*rhodz/CLDMC(l,i,j) - AIJL(i,j,l,ijl_QLrad) & - = AIJL(i,j,l,ijl_QLrad) + QLMC(l,i,j) & - *PDSIG(l,i,j)/CLDMC(l,i,j) -#ifdef CFMIP3_SUBDD - ! MC Cloud Liquid - cfmip_twp(i,j) = cfmip_twp(i,j) & - + QLMC(l,i,j)*rhodz/CLDMC(l,i,j) - cfmip_qcl(i,j,l) = QLMC(l,i,j) & - /CLDMC(l,i,j) -#endif - ELSE - TAUIC(L) = cldx*TAUMCL - OPTDI = OPTDI + TAUIC(L) -#ifdef GCAP - TAUI3D(I,J,L) = TAUI3D(I,J,L) + TAUMCL - ! in-cloud vs. in-cell TAUIC(L) -#endif - CALL INC_AJL(i,j,l,jl_icld,1D0) - CALL INC_AJL(i,j,l,jl_icldwt,PDSIG(l,i,j)) - AIJ(i,j,ij_iwprad) = AIJ(i,j,ij_iwprad) & - + QIMC(l,i,j)*rhodz/CLDMC(l,i,j) - AIJL(i,j,l,ijl_QIrad) & - = AIJL(i,j,l,ijl_QIrad) + QIMC(l,i,j) & - *PDSIG(l,i,j)/CLDMC(l,i,j) -#ifdef CFMIP3_SUBDD - ! MC Cloud Ice - cfmip_twp(i,j) = cfmip_twp(i,j) & - + QIMC(l,i,j)*rhodz/CLDMC(l,i,j) - cfmip_qci(i,j,l) = QIMC(l,i,j) & - /CLDMC(l,i,j) -#endif - ENDIF - ELSE - SS_CLD(L) = 1. - SIZEWC(L) = CSIZSS(L,I,J) - SIZEIC(L) = CSIZSS(L,I,J) - IF ( SVLHX(L,I,J)==LHE ) THEN - TAUWC(L) = cldx*TAUSSL - OPTDW = OPTDW + TAUWC(L) -#ifdef GCAP - TAUW3D(I,J,L) = TAUW3D(I,J,L) + TAUSSL - ! in-cloud vs. in-cell TAUWC(L) -#endif - CALL INC_AJL(i,j,l,jl_wcld,1D0) - CALL INC_AJL(i,j,l,jl_wcldwt,PDSIG(l,i,j)) - AIJ(i,j,ij_lwprad) = AIJ(i,j,ij_lwprad) & - + QLSS(l,i,j)*rhodz/CLDSS(l,i,j) - AIJL(i,j,l,ijl_QLrad) & - = AIJL(i,j,l,ijl_QLrad) + QLSS(l,i,j) & - *PDSIG(l,i,j)/CLDSS(l,i,j) -#ifdef CFMIP3_SUBDD - ! LS Cloud Liquid - cfmip_twp(i,j) = cfmip_twp(i,j) & - + QLSS(l,i,j)*rhodz/CLDSS(l,i,j) - cfmip_qcl(i,j,l) = QLSS(l,i,j) & - /CLDSS(l,i,j) -#endif - IF ( tausslip>0. ) THEN - SIZEIC(L) = CSIZSSIP(L,I,J) - TAUIC(L) = cldx*TAUSSLIP - OPTDI = OPTDI + TAUIC(L) -#ifdef GCAP - TAUI3D(I,J,L) = TAUI3D(I,J,L) & - + TAUSSLIP ! in-cloud vs. in-cell TAUIC(L) -#endif - CALL INC_AJL(i,j,l,jl_icld,1D0) - CALL INC_AJL(i,j,l,jl_icldwt, & - PDSIG(l,i,j)) - AIJ(i,j,ij_iwprad) = AIJ(i,j,ij_iwprad)& - + QISS(l,i,j)*rhodz/CLDSS(l,i,j) - AIJL(i,j,l,ijl_QIrad) & - = AIJL(i,j,l,ijl_QIrad) & - + QISS(l,i,j)*PDSIG(l,i,j) & - /CLDSS(l,i,j) -#ifdef CFMIP3_SUBDD - ! LS Snow in supercooled liquid - cfmip_twp(i,j) = cfmip_twp(i,j) & - + QISS(l,i,j)*rhodz/CLDSS(l,i,j) -#endif - ENDIF - ELSE - TAUIC(L) = cldx*TAUSSL - OPTDI = OPTDI + TAUIC(L) -#ifdef GCAP - TAUI3D(I,J,L) = TAUI3D(I,J,L) + TAUSSL - ! in-cloud vs. in-cell TAUIC(L) -#endif - CALL INC_AJL(i,j,l,jl_icld,1D0) - CALL INC_AJL(i,j,l,jl_icldwt,PDSIG(l,i,j)) - AIJ(i,j,ij_iwprad) = AIJ(i,j,ij_iwprad) & - + QISS(l,i,j)*rhodz/CLDSS(l,i,j) - AIJL(i,j,l,ijl_QIrad) & - = AIJL(i,j,l,ijl_QIrad) + QISS(l,i,j) & - *PDSIG(l,i,j)/CLDSS(l,i,j) -#ifdef CFMIP3_SUBDD - ! LS Cloud Ice - cfmip_twp(i,j) = cfmip_twp(i,j) & - + QISS(l,i,j)*rhodz/CLDSS(l,i,j) - cfmip_qci(i,j,l) = QISS(l,i,j) & - /CLDSS(l,i,j) -#endif - ENDIF - ENDIF - CALL INC_AJL(i,j,l,jl_wcod,TAUWC(l)) - CALL INC_AJL(i,j,l,jl_icod,TAUIC(l)) - CALL INC_AJL(i,j,l,jl_wcsiz,SIZEWC(l)*TAUWC(l)) - CALL INC_AJL(i,j,l,jl_icsiz,SIZEIC(l)*TAUIC(l)) - AIJL(i,j,l,ijl_wtrtau) = AIJL(i,j,l,ijl_wtrtau) & - + TAUWC(l) - AIJL(i,j,l,ijl_icetau) = AIJL(i,j,l,ijl_icetau) & - + TAUIC(l) - wtrtau(i,j,l) = TAUWC(l) - icetau(i,j,l) = TAUIC(l) - ENDIF - !**** save some radiation/cloud fields for wider use - RCLD(L,I,J) = TAUWC(L) + TAUIC(L) - ENDDO - CFRAC(I,J) = CLDCV - ! cloud fraction consistent with radiation - !**** effective cloud cover diagnostics - OPNSKY = 1. - CLDCV - DO IT = 1, NTYPE - CALL INC_AJ(i,j,it,J_PCLDSS,CSS*FTYPE(IT,I,J)) - CALL INC_AJ(i,j,it,J_PCLDMC,CMC*FTYPE(IT,I,J)) - CALL INC_AJ(i,j,it,J_CLDDEP,DEPTH*FTYPE(IT,I,J)) - CALL INC_AJ(i,j,it,J_PCLD,CLDCV*FTYPE(IT,I,J)) - ENDDO - CALL INC_AREG(i,j,jr,J_PCLDSS,CSS) - CALL INC_AREG(i,j,jr,J_PCLDMC,CMC) - CALL INC_AREG(i,j,jr,J_CLDDEP,DEPTH) - CALL INC_AREG(i,j,jr,J_PCLD,CLDCV) - AIJ(I,J,IJ_PMCCLD) = AIJ(I,J,IJ_PMCCLD) + CMC - AIJ(I,J,IJ_CLDCV) = AIJ(I,J,IJ_CLDCV) + CLDCV - DO L = 1, LLOW - ! LTM : Fix, testing equality of reals is not reliable - IF ( TOTCLD(L)/=1. ) CYCLE - AIJ(I,J,IJ_PCLDL) = AIJ(I,J,IJ_PCLDL) + 1. - EXIT - ENDDO - DO L = LLOW + 1, LMID - ! LTM : Fix, testing equality of reals is not reliable - IF ( TOTCLD(L)/=1. ) CYCLE - AIJ(I,J,IJ_PCLDM) = AIJ(I,J,IJ_PCLDM) + 1. - EXIT - ENDDO - DO L = LMID + 1, LHI - ! LTM : Fix, testing equality of reals is not reliable - IF ( TOTCLD(L)/=1. ) CYCLE - AIJ(I,J,IJ_PCLDH) = AIJ(I,J,IJ_PCLDH) + 1. - EXIT - ENDDO - DO L = 1, LLOW - ! LTM : Fix, testing equality of reals is not reliable - IF ( SS_CLD(L)/=1. ) CYCLE - AIJ(I,J,IJ_PCLDL_SS) = AIJ(I,J,IJ_PCLDL_SS) + 1. - EXIT - ENDDO - - TAUSUMW(I,J) = OPTDW - TAUSUMI(I,J) = OPTDI - IF ( optdw>0. ) THEN - AIJ(I,J,IJ_optdw) = AIJ(I,J,IJ_optdw) + optdw - AIJ(I,J,IJ_wtrcld) = AIJ(I,J,IJ_wtrcld) + 1. - WTRCLD(I,J) = 1. - ENDIF - IF ( optdi>0. ) THEN - AIJ(I,J,IJ_optdi) = AIJ(I,J,IJ_optdi) + optdi - AIJ(I,J,IJ_icecld) = AIJ(I,J,IJ_icecld) + 1. - ICECLD(I,J) = 1. - ENDIF - - DO KR = 1, NDIUPT - IF ( I==IJDD(1,KR) .AND. J==IJDD(2,KR) ) THEN - !**** Warning : this replication may give inaccurate results for hours - !**** 1->(NRAD-1)*DTsrc (ADIURN) or skip them (HDIURN) - TMP(IDD_CL7 : IDD_CL7+6) = TOTCLD(1 : 7) - TMP(IDD_CCV) = CLDCV - DO INCH = 1, NRAD - IHM = 1 + (JTIME+INCH-1)*HR_IN_DAY/NDAY - IH = IHM - IF ( IH>HR_IN_DAY ) IH = IH - HR_IN_DAY - ADIURN(IDX( : ),KR,IH) = ADIURN(IDX( : ),KR,IH) & - + TMP(IDX( : )) -#ifdef USE_HDIURN - IHM = IHM + (DATE-1)*HR_IN_DAY - IF ( IHM<=HR_IN_MONTH ) HDIURN(IDX( : ),KR,IHM)& - = HDIURN(IDX( : ),KR,IHM) + TMP(IDX( : )) -#endif - ENDDO - ENDIF - ENDDO - ENDIF - ! kradia le 0 (full model) - !**** - !**** SET UP VERTICAL ARRAYS OMITTING THE I AND J INDICES - !**** - !**** EVEN PRESSURES -#ifdef TRACERS_TOMAS - aesqex( : , : , : ) = 0.0 - aesqsc( : , : , : ) = 0.0 - aesqcb( : , : , : ) = 0.0 - aesqex_dry( : , : , : ) = 0.0 - aesqsc_dry( : , : , : ) = 0.0 - aesqcb_dry( : , : , : ) = 0.0 -#endif - PLB(LM+1) = PEDN(LM+1,I,J) - DO L = 1, LM - PLB(L) = PEDN(L,I,J) - !**** TEMPERATURES - !---- TLm(L)=T(I,J,L)*PK(L,I,J) ! already defined - IF ( INT(TLM(L))=planck_tmax ) THEN - WRITE (6,*) 'In Radia : Time,I,J,L,TL', ITime, I, J,& - L, TLM(L) - WRITE (6,*) 'GTEMPR : ', ASFLX4(1)%GTEMPR(I,J), & - ASFLX4(2)%GTEMPR(I,J), ASFLX4(3) & - %GTEMPR(I,J), ASFLX4(4)%GTEMPR(I,J) - !CC STOP 'In Radia : Temperature out of range' - ! ICKERR=ICKERR+1 - ENDIF - !**** MOISTURE VARIABLES - !---- shl(L)=Q(I,J,L) ! already defined and reset to 0 if <0 - ! if(shl(l).lt.0.) then - ! WRITE(0,*)'In Radia : Time,I,J,L,QL<0',ITime,I,J,L,shl(L),'->0' - ! KCKERR=KCKERR+1 - ! shl(l)=0. - ! end if - RHL(L) = SHL(L)/QSAT(TLM(L),LHE,PMID(L,I,J)) - IF ( RHfix>=0. ) RHL(L) = RHfix - !**** Extra aerosol data - !**** For up to nraero_aod aerosols, define the aerosol amount to - !**** be used (kg/m^2) - !**** Only define TRACER if individual tracer is actually defined. -#if (defined TRACERS_AEROSOLS_Koch) || (defined TRACERS_DUST) ||\ - (defined TRACERS_MINERALS) || (defined TRACERS_AEROSOLS_SEASALT) - !**** loop over tracers that are passed to radiation. - !**** Some special cases for black carbon, organic carbon, SOAs where - !**** more than one tracer is lumped together for radiation purposes - DO n = 1, nraero_aod - SELECT CASE (TRNAME(NTRIX_AOD(n))) - CASE ("OCIA","vbsAm2") -#ifdef TRACERS_AEROSOLS_VBS - TRACER(L,n) = SUM(TRM(i,j,l,vbs_tr%IAER)) -#else - TRACER(L,n) = TRM(i,j,l,n_OCII) & - + TRM(i,j,l,n_OCIA) -#endif /* TRACERS_AEROSOLS_VBS */ -#ifdef TRACERS_AEROSOLS_OCEAN - TRACER(L,n) = TRACER(L,n) + TRM(i,j,l,n_ococean) -#endif /* TRACERS_AEROSOLS_OCEAN */ - TRACER(L,n) = TRACER(L,n)*BYAXYP(I,J) - CASE ("OCB") -#ifdef TRACERS_AEROSOLS_VBS - TRACER(L,n) = 0.D0 -#else - TRACER(L,n) = TRM(i,j,l,n_OCB)*BYAXYP(I,J) -#endif /* TRACERS_AEROSOLS_VBS */ -#ifdef TRACERS_AEROSOLS_SOA - CASE ("isopp1a") - TRACER(L,n) = TRM(i,j,l,n_isopp1a) & - + TRM(i,j,l,n_isopp2a) -#ifdef TRACERS_TERP - TRACER(L,n) = TRACER(L,n) + TRM(i,j,l,n_apinp1a)& - + TRM(i,j,l,n_apinp2a) -#endif /* TRACERS_TERP */ - TRACER(L,n) = TRACER(L,n)*BYAXYP(I,J) -#endif /* TRACERS_AEROSOLS_SOA */ - CASE ("BCIA") - TRACER(L,n) = (TRM(i,j,l,n_BCII)+TRM(i,j,l, & - n_BCIA))*BYAXYP(I,J) - CASE DEFAULT -#ifdef TRACERS_NITRATE - ! assume full neutralization of NO3p, if NH4 suffice - SELECT CASE (TRNAME(NTRIX_AOD(n))) - CASE ("NO3p") - IF ( TRM(i,j,l,NTRIX_AOD(n))>0.D0 ) THEN - nh4_on_no3 = MIN(TRM(i,j,l,n_NO3p) & - *(TR_MM(n_NO3p)+TR_MM(n_NH4)) & - /TR_MM(n_NO3p)-TRM(i,j,l,n_NO3p), & - TRM(i,j,l,n_NH4)) - WTTR(n) = (nh4_on_no3+TRM(i,j,l,NTRIX_AOD(& - n)))/TRM(i,j,l,NTRIX_AOD(n)) - ENDIF - CASE ("SO4") - IF ( TRM(i,j,l,NTRIX_AOD(n))>0.D0 ) THEN - nh4_on_no3 = MIN(TRM(i,j,l,n_NO3p) & - *(TR_MM(n_NO3p)+TR_MM(n_NH4)) & - /TR_MM(n_NO3p)-TRM(i,j,l,n_NO3p), & - TRM(i,j,l,n_NH4)) - WTTR(n) = (TRM(i,j,l,n_NH4)-nh4_on_no3+TRM& - (i,j,l,NTRIX_AOD(n))) & - /TRM(i,j,l,NTRIX_AOD(n)) - ENDIF - ENDSELECT -#endif - TRACER(L,n) = WTTR(n)*TRM(i,j,l,NTRIX_AOD(n)) & - *BYAXYP(I,J) - ENDSELECT - ENDDO -#endif /* TRACERS_AEROSOLS_Koch/DUST/MINERALS/SEASALT */ - -#ifdef TRACERS_AMP - CALL SETAMP_LEV(i,j,l) -#endif -#ifdef TRACERS_TOMAS - CALL SETTOMAS_LEV(i,j,l) -#endif - ENDDO - !**** Radiative Equilibrium Layer data - DO K = 1, LM_REQ - !CC STOP 'In Radia : RQT out of range' - ! JCKERR=JCKERR+1 - IF ( INT(RQT(K,I,J))=planck_tmax ) WRITE (6,*) & - 'In RADIA : Time,I,J,L,TL', ITime, I, J, LM + K, & - RQT(K,I,J) - TLM(LM+K) = RQT(K,I,J) - PLB(LM+k+1) = PLB0(k) - SHL(LM+k) = SHL0(k) - RHL(LM+k) = SHL(LM+k) & - /QSAT(TLM(LM+k),LHE,.5D0*(PLB(LM+k) & - +PLB(LM+k+1))) - TAUWC(LM+k) = 0. - TAUIC(LM+k) = 0. - SIZEWC(LM+k) = 0. - SIZEIC(LM+k) = 0. -#ifdef TRACERS_ON - !**** set radiative equilibrium extra tracer amount to zero - IF ( nraero_aod>0 ) TRACER(LM+k,1 : nraero_aod) = 0. -#endif - ENDDO - IF ( kradia>1 ) THEN - DO l = 1, lm + lm_req - TLM(l) = TLM(l) + TCHG(l,i,j) - AFLX_ST(L,I,J,5) = AFLX_ST(L,I,J,5) + TCHG(L,I,J) - ENDDO - ENDIF - !**** Zenith angle and GROUND/SURFACE parameters - COSZ = COSZA(I,J) - TGO = atmocn%GTEMPR(I,J) - TGOI = atmice%GTEMPR(I,J) - TGLI = atmgla%GTEMPR(I,J) - TGE = atmlnd%GTEMPR(I,J) - TSL = atmsrf%TSAVG(I,J) - SNOWOI = SNOWI(I,J) - SNOWLI = atmgla%SNOW(I,J) - !SNOWE=atmlnd%SNOWE(I,J) ! snow depth (kg/m**2) - SNOWD( : ) = snowd_ij( : ,I,J) - snow_frac( : ) = atmlnd%FR_SNOW_RAD( : ,i,j) - ! snow cover (1) - AGESN(1) = SNOAGE(3,I,J) - ! land ! ? why are these numbers - AGESN(2) = SNOAGE(1,I,J) - ! ocean ice so confusing ? - AGESN(3) = SNOAGE(2,I,J) - ! land ice - ! print*,"snowage",i,j,SNOAGE(1,I,J) - !**** set up parameters for new sea ice and snow albedo - zsnwoi = atmice%ZSNOWI(I,J) - ! LTM : Fix, testing equality of reals is not reliable - IF ( dalbsnX/=0. ) THEN -#ifdef OLD_BCdalbsn - dALBsn = xdalbs*DEPOBC(i,j) -#else - dALBsn = dalbsnX*BCDALBSN(i,j) -#endif - ELSE - dALBsn = 0. - ENDIF - - ! to use on-line tracer albedo impact, set dALBsnX=0. in rundeck -#ifdef BC_ALB - CALL GET_BC_DALBEDO(i,j,dALBsn1,bc_snow_present(i,j)) - IF ( rad_interact_aer>0 ) dALBsn = dALBsn1 - dALBsnBC(I,J) = dALBsn1 -#endif /* BC_ALB */ - IF ( poice>0. ) THEN - zoice = ZSI(i,j) - flags = flag_dsws(i,j) - IF ( kradia<=0 ) THEN - fmp = MIN(1.6D0*SQRT(pond_melt(i,j)/rhow),1D0) - AIJ(I,J,IJ_FRMP) = AIJ(I,J,IJ_FRMP) + fmp*POICE - ELSE - fmp = fmp_com(i,j) - ENDIF - zmp = MIN(0.8D0*fmp,0.9D0*zoice) - ELSE - zoice = 0. - flags = .FALSE. - fmp = 0. - zmp = 0. - ENDIF - !**** set up new lake depth parameter to incr. albedo for shallow lakes - ! zlake=0. - ! if (plake.gt.0) then - ! zlake = MWL(I,J)/(RHOW*PLAKE*AXYP(I,J)) - ! end if - zlake = dlake(i,j) - !**** - IF ( kradia<=0 ) THEN - !WEARTH=(WEARTH_COM(I,J)+AIEARTH(I,J))/(WFCS(I,J)+1.D-20) - WEARTH = atmlnd%BARE_SOIL_WETNESS(i,j) - IF ( wearth>1. ) wearth = 1. - ELSE ! rad.frc. model - wearth = wsoil(i,j) - ENDIF - IF ( FEARTH(i,j)>0.D0 ) THEN - CALL ENT_GET_EXPORTS(ENTCELLS(i,j), & - VEGETATION_FRACTIONS=PVT0, & - VEGETATION_HEIGHTS=HVT0) - CALL MAP_ENT2GISS(PVT0,HVT0,PVT) - !temp hack : ent pfts->giss veg - ELSE - PVT( : ) = 0.D0 - ! actually PVT is not supposed to be used in this case - ENDIF - WMAG = atmsrf%WSAVG(I,J) - !**** - !**** Radiative interaction and forcing diagnostics : - !**** If no radiatively active tracers are defined, nothing changes. - !**** Currently this works for aerosols and ozone but should be extended - !**** to cope with all trace gases. - !**** - FTAUC = 1. - ! deflt (clouds on) - use_tracer_chem(:) = 0 - ! by default use climatological ozone/ch4/co2 - !**** Set level for inst. rad. forc. calcs for aerosols/trace gases - !**** This is set from the rundeck. - LFRC = LM + LM_REQ + 1 - ! TOA - IF ( rad_forc_lev>0 ) LFRC = LTROPO(I,J) - ! TROPOPAUSE -#ifdef ACCMIP_LIKE_DIAGS - IF ( rad_forc_lev>0 ) CALL STOP_MODEL( & - &'ACCMIP_LIKE_DIAGS desires TOA RADF diags',255) -#endif - !**** The calculation of the forcing is slightly different. - !**** depending on whether full radiative interaction is turned on - !**** or not. - onoff_aer = 0 - onoff_chem = 0 - IF ( rad_interact_aer > 0 ) onoff_aer = 1 - IF ( clim_interact_chem > 0 ) onoff_chem = 1 - use_o3_ref = 0 - -#ifdef TRACERS_GC - - IF ( SUM( TrM(I,J,1:LM,i_CH4) ) .lt. 1d-20 ) THEN - ! If methane is not initialized yet assume 1.5 ppmv everywhere - CHEM_IN(2,1:LM) = MA(1:LM,I,J) * 1.5e-6 * 16.04 / 28.97 - ELSE - !IF ( i_CH4 > 0 ) - IF ( Am_I_Root() .and. I .eq. 1 .and. J .eq. 1 ) & - WRITE(6,*) 'Updating methane in radiation code...' - CHEM_IN(2,1:LM) = TrM(I,J,1:LM,i_CH4) * BYAXYP(I,J) - ENDIF - - IF ( SUM( TrM(I,J,1:LM,i_O3) ) .lt. 1d-20 ) THEN - ! If ozone is not initialized yet assume 5 ppmv everywhere - CHEM_IN(1,1:LM) = MA(1:LM,I,J) * 5.0e-6 * 47.997 / 28.97 - ELSE - !IF ( i_O3 > 0 ) - IF ( Am_I_Root() .and. I .eq. 1 .and. J .eq. 1 ) & - WRITE(6,*) 'Updating ozone in radiation code...' - CHEM_IN(1,1:LM) = TrM(I,J,1:LM, i_O3) * BYAXYP(I,J) - ENDIF - - IF ( clim_interact_chem > 0 ) THEN - use_tracer_chem(1) = LM ! Lmax_rad_O3 ! O3 - use_tracer_chem(2) = LM ! Lmax_rad_CH4 ! CH4 - ENDIF -#endif - -#ifdef TRACERS_SPECIAL_Shindell - !**** Ozone and Methane : - CHEM_IN(1,1:LM) = chem_tracer_save(1,1:LM, I,J) - CHEM_IN(2,1:LM) = chem_tracer_save(2,1:LM, I,J) & - *CH4X_RADoverCHEM - IF ( clim_interact_chem>0 ) THEN - use_tracer_chem(1) = Lmax_rad_O3 - ! O3 - use_tracer_chem(2) = Lmax_rad_CH4 - ! CH4 - ENDIF -#if (defined SHINDELL_STRAT_EXTRA) &(defined ACCMIP_LIKE_DIAGS) - IF ( clim_interact_chem<=0 ) CALL STOP_MODEL( & - &"stratOx RADF on, clim_interact_chem<=0",255) -#endif /* SHINDELL_STRAT_EXTRA &ACCMIP_LIKE_DIAGS */ -#endif /* TRACERS_SPECIAL_Shindell */ - - !**** CO2 - ! Update GCCco2_IN and GCCco2_tracer_save with trm to pass on CO2 - ! information to RADIATION -#ifdef GCC_COUPLE_RAD - DO L = 1, LM - GCCCO2_TRACER_SAVE(L,i,j) = (TRM(i,j,L,n_CO2n)) & - *BYAXYP(i,j)*avog/(TR_MM(n_CO2n)*2.69E20) - ENDDO - GCCco2_IN(1:LM) = GCCCO2_TRACER_SAVE(1:LM, I,J)*CO2X - use_tracer_GCCco2 = Lmax_rad_CO2 - ! CO2 -#endif /* GCC_COUPLE_RAD */ - - IF ( moddrf==0 ) THEN -#if (defined TRACERS_AEROSOLS_Koch) || (defined TRACERS_DUST) ||\ - (defined TRACERS_MINERALS) || (defined TRACERS_AEROSOLS_SEASALT) ||\ - (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - !**** Aerosols (OMA, MATRIX, TOMAS) : - DO n = 1, nraero_rf - IF ( TRNAME(NTRIX_RF(n))=="seasalt2" ) CYCLE - ! not for seasalt2 - IF ( diag_fc==2 ) THEN - FSTOPX(n) = 1 - onoff_aer - !turns off online tracer - FTTOPX(n) = 1 - onoff_aer - ! - !**** Warning : small bit of hardcoding assumes that seasalt2 immediately - !**** succeeds seasalt1 in nraero_rf array - IF ( TRNAME(NTRIX_RF(n))=="seasalt1" ) THEN - !add seasalt2 - FSTOPX(n+1) = 1 - onoff_aer - FTTOPX(n+1) = 1 - onoff_aer !to seasalt1 - ENDIF - ELSEIF ( diag_fc==1 ) THEN - FSTOPX(1 : nraero_aod) = 1 - onoff_aer - !turns off online tracer - FTTOPX(1 : nraero_aod) = 1 - onoff_aer - ! - ENDIF -#if (defined TRACERS_AEROSOLS_Koch) || (defined TRACERS_DUST) ||\ - (defined TRACERS_MINERALS) || (defined TRACERS_AEROSOLS_SEASALT) - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) -#endif - CALL RCOMPX - ! tr.aero.Koch/dust/miner./seasalt - SNFST(1,n,I,J) = SRNFLB(1) - ! surface forcing - TNFST(1,n,I,J) = TRNFLB(1) - SNFST(2,n,I,J) = SRNFLB(LFRC) - ! Tropopause forcing - TNFST(2,n,I,J) = TRNFLB(LFRC) - IF ( diag_fc==2 ) THEN - FSTOPX(n) = onoff_aer - !turns on online tracer - FTTOPX(n) = onoff_aer - ! - IF ( TRNAME(NTRIX_RF(n))=="seasalt1" ) THEN - ! also for seasalt2 - FSTOPX(n+1) = onoff_aer - FTTOPX(n+1) = onoff_aer - ENDIF - ELSEIF ( diag_fc==1 ) THEN - FSTOPX(1 : nraero_aod) = onoff_aer - !turns on online tracer - FTTOPX(1 : nraero_aod) = onoff_aer - ! - ENDIF - ENDDO -#endif - -#ifdef TRACERS_GC - ! Get flux values minus ozone at various heights - ! Use constant reference year for first call as with Shindell tracers - !use_o3_ref = 1 - ! Do not use constant reference year - use_o3_ref = 0 - use_tracer_chem(1) = 0 - kdeliq( 1:LM, 1:4 ) = kliq( 1:LM, 1:4, i, j ) - CALL RCOMPX - ! Meteorological tropopause - SNFST_o3ref(1,I,J) = SRNFLB(LTROPO(I,J)) - TNFST_o3ref(1,I,J) = TRNFLB(LTROPO(I,J)) - ! Top of the atmosphere - SNFST_o3ref(2,I,J) = SRNFLB(LM+LM_REQ+1) - TNFST_o3ref(2,I,J) = TRNFLB(LM+LM_REQ+1) - ! Whole atmosphere - SNFS_3D_pert(I,J,:,5) = SRNFLB - TNFS_3D_pert(I,J,:,5) = TRNFLB - - use_o3_ref = 0 - use_tracer_chem(1) = onoff_chem * LM !Lmax_rad_O3 - - IF ( SUM( TrM(I,J,1:LM,i_CH4) ) .lt. 1d-20 ) THEN - ! If methane is not initialized yet assume 1.5 ppmv everywhere - CHEM_IN(2,1:LM) = MA(1:LM,I,J) * 1.5e-6 * 16.04 / 28.97 - ELSE - !IF ( i_CH4 > 0 ) - CHEM_IN(2,1:LM) = TrM(I,J,1:LM,i_CH4) * BYAXYP(I,J) - ENDIF - - IF ( SUM( TrM(I,J,1:LM,i_O3) ) .lt. 1d-20 ) THEN - ! If ozone is not initialized yet assume 5 ppmv everywhere - CHEM_IN(1,1:LM) = MA(1:LM,I,J) * 5.0e-6 * 47.997 / 28.97 - ELSE - !IF ( i_O3 > 0 ) - CHEM_IN(1,1:LM) = TrM(I,J,1:LM, i_O3) * BYAXYP(I,J) - ENDIF - -#endif - -#ifdef TRACERS_SPECIAL_Shindell - !**** Ozone : - ! ozone rad forcing diags now use a constant reference year - ! for this first call. And no tracer values... - use_o3_ref = 1 - use_tracer_chem(1) = 0 - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX - ! tr_Shindell Ox tracer - SNFST_o3ref(1,I,J) = SRNFLB(LTROPO(I,J)) - ! meteorological tropopause - TNFST_o3ref(1,I,J) = TRNFLB(LTROPO(I,J)) - SNFST_o3ref(2,I,J) = SRNFLB(LM+LM_REQ+1) - ! T.O.A. - TNFST_o3ref(2,I,J) = TRNFLB(LM+LM_REQ+1) - SNFST_o3ref(5,I,J) = SRNFLB(LS1-1) - ! fixed tropopause - TNFST_o3ref(5,I,J) = TRNFLB(LS1-1) - -#ifdef AUXILIARY_OX_RADF - ! if needed, also save the auxiliary ozone field (i.e. climatology - ! if tracer is used in final call, tracers if climatology is used.) -#ifdef AUX_OX_RADF_TROP - ! forces use of tracer from L=1,LS1-1 and reference above that : - use_o3_ref = 1 - use_tracer_chem(1) = LS1 - 1 -#else - ! use tracer or climatology, whichever won''t be used in final call : - use_o3_ref = 0 - use_tracer_chem(1) = (1-onoff_chem)*Lmax_rad_O3 -#endif - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX - ! tr_Shindell Ox tracer -#ifdef AUX_OX_RADF_TROP - SNFST_o3ref(3,I,J) = SRNFLB(LS1-1) - ! fixed tropopause - TNFST_o3ref(3,I,J) = TRNFLB(LS1-1) -#else - SNFST_o3ref(3,I,J) = SRNFLB(LTROPO(I,J)) - ! meteorological tropopause - TNFST_o3ref(3,I,J) = TRNFLB(LTROPO(I,J)) -#endif - SNFST_o3ref(4,I,J) = SRNFLB(LM+LM_REQ+1) - ! T.O.A. - TNFST_o3ref(4,I,J) = TRNFLB(LM+LM_REQ+1) -#endif /* AUXILIARY_OX_RADF */ - ! After AUX call, use either climatological or tracer O3 : - use_o3_ref = 0 - use_tracer_chem(1) = onoff_chem*Lmax_rad_O3 -#if (defined SHINDELL_STRAT_EXTRA) && (defined ACCMIP_LIKE_DIAGS) - ! Optional intermediate call with stratOx tracer : - !NEED CHEM_IN(1,1:LM)=stratO3_tracer_save(1:LM, I,J) - !NEED kdeliq(1:LM, 1:4)=kliq(1:LM, 1:4,i,j) - !NEED CALL RCOMPX ! stratOx diag tracer - ! Tropopause - SNFST_stratOx(1,I,J) = SRNFLB(LTROPO(I,J)) - TNFST_stratOx(1,I,J) = TRNFLB(LTROPO(I,J)) - ! T.O.A. - SNFST_stratOx(2,I,J) = SRNFLB(LM+LM_REQ+1) - TNFST_stratOx(2,I,J) = TRNFLB(LM+LM_REQ+1) -#endif /* SHINDELL_STRAT_EXTRA && ACCMIP_LIKE_DIAGS */ - CHEM_IN(1,1:LM) = chem_tracer_save(1,1:LM, I,J) ! Ozone - CHEM_IN(2,1:LM) = chem_tracer_save(2,1:LM, I,J) * CH4X_RADoverCHEM ! Methane -#if (defined ACCMIP_LIKE_DIAGS) -#ifndef SKIP_ACCMIP_GHG_RADF_DIAGS - ! TOA GHG rad forcing : nf=1,4 are CH4, N2O, CFC11, CFC12 : - ! Initial calls are reference year/day : - DO nf = 1, 4 - IF ( nf==1 ) THEN - ! CH4 reference call must not use tracer - use_tracer_chem(2) = 0 - ELSE - ! N2O and CFC call's CH4 should match final call - use_tracer_chem(2) = onoff_chem*Lmax_rad_CH4 - ENDIF - FULGAS(nfghg(nf)) = sv_fulgas_ref(nf) - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX - SNFS_ghg(nf,I,J) = SRNFLB(LM+LM_REQ+1) - TNFS_ghg(nf,I,J) = TRNFLB(LM+LM_REQ+1) - FULGAS(nfghg(nf)) = sv_fulgas_now(nf) - ENDDO -#endif /* NOT DEFINED SKIP_ACCMIP_GHG_RADF_DIAGS */ -#endif /* ACCMIP_LIKE_DIAGS */ -#endif /* TRACERS_SPECIAL_Shindell */ - -#if defined ( TRACERS_GC ) - - IF ( SUM( TrM(I,J,1:LM,i_CH4) ) .lt. 1d-20 ) THEN - ! If methane is not initialized yet assume 1.5 ppmv everywhere - CHEM_IN(2,1:LM) = MA(1:LM,I,J) * 1.5e-6 * 16.04 / 28.97 - ELSE - !IF ( i_CH4 > 0 ) - CHEM_IN(2,1:LM) = TrM(I,J,1:LM,i_CH4) * BYAXYP(I,J) - ENDIF - - IF ( SUM( TrM(I,J,1:LM,i_O3) ) .lt. 1d-20 ) THEN - ! If ozone is not initialized yet assume 5 ppmv everywhere - CHEM_IN(1,1:LM) = MA(1:LM,I,J) * 5.0e-6 * 47.997 / 28.97 - ELSE - !IF ( i_O3 > 0 ) - CHEM_IN(1,1:LM) = TrM(I,J,1:LM, i_O3) * BYAXYP(I,J) - ENDIF - - ! TOA GHG rad forcing : nf=1,4 are CH4, N2O, CFC11, CFC12 : - ! Initial calls are reference year/day : - DO nf = 1, 4 - IF ( nf==1 ) THEN - ! CH4 reference call must not use tracer - use_tracer_chem(2) = 0 - ELSE - ! N2O and CFC call's CH4 should match final call - use_tracer_chem(2) = onoff_chem*LM ! Lmax_rad_CH4 - ENDIF - FULGAS(nfghg(nf)) = sv_fulgas_ref(nf) - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX - ! TOA - SNFS_ghg(nf,I,J) = SRNFLB(LM+LM_REQ+1) - TNFS_ghg(nf,I,J) = TRNFLB(LM+LM_REQ+1) - ! Tropopause - SNFS_ghg_tp(nf,I,J) = SRNFLB(LTROPO(I,J)) - TNFS_ghg_tp(nf,I,J) = TRNFLB(LTROPO(I,J)) - ! Whole atmosphere - SNFS_3D_pert(I,J,:,nf) = SRNFLB - TNFS_3D_pert(I,J,:,nf) = TRNFLB - FULGAS(nfghg(nf)) = sv_fulgas_now(nf) - ENDDO - -#endif - - ENDIF - ! moddrf=0 -#if (defined GCC_COUPLE_RAD) - ! final (main) RCOMPX call can use tracer co2 (or not) : - use_tracer_GCCco2 = Lmax_rad_CO2 - IF ( IS_SET_PARAM('initial_GHG_setup') ) THEN - CALL GET_PARAM('initial_GHG_setup',initial_GHG_setup) - IF ( initial_GHG_setup==1 .AND. itime==itimeI ) & - use_tracer_GCCco2 = 0 - ! special case; model outputs climatology - ENDIF -#endif /* GCC_COUPLE_RAD */ -#if (defined TRACERS_SPECIAL_Shindell) - ! final (main) RCOMPX call can use tracer methane (or not) : - use_tracer_chem(2) = onoff_chem*Lmax_rad_CH4 - IF ( IS_SET_PARAM('initial_GHG_setup') ) THEN - CALL GET_PARAM('initial_GHG_setup',initial_GHG_setup) - IF ( initial_GHG_setup==1 .AND. itime==itimeI ) & - use_tracer_chem(2) = 0 - ! special case; model outputs climatology - ENDIF -#endif /* TRACERS_SPECIAL_Shindell */ - -#ifdef GCC_UNCOUPLE_RAD_CONCEN - ! Use reference year CO2 for uncoupling radiation - FULGAS(2) = GCCco2_fulgas_ref -#endif - - IF ( moddrf==0 ) THEN -#ifdef BC_ALB - IF ( rad_interact_aer>0 ) dalbsn = 0.D0 - CALL RCOMPX - NFSNBC(I,J) = SRNFLB(LM+LM_REQ+1) - ! NFSNBC(I,J)=SRNFLB(LFRC) - ALBNBC(I,J) = SRNFLB(1)/(SRDFLB(1)+1.D-20) - ! set for BC-albedo effect - IF ( rad_interact_aer>0 ) dALBsn = dALBsn1 -#endif - !**** Optional calculation of CRF using a clear sky calc. - IF ( cloud_rad_forc>0 ) THEN - FTAUC = 0. - ! turn off cloud tau (tauic +tauwc) - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX - ! cloud_rad_forc>0 : clr sky - SNFSCRF(I,J) = SRNFLB(LM+LM_REQ+1) - ! always TOA - TNFSCRF(I,J) = TRNFLB(LM+LM_REQ+1) - ! always TOA - LWDNCS(I,J) = STBO*(POCEAN*atmocn%GTEMPR(I,J)**4+ & - POICE*atmice%GTEMPR(I,J) & - **4+PLICE*atmgla%GTEMPR(I,J) & - **4+PEARTH*atmlnd%GTEMPR(I,J)**4) & - - TRNFLB(1) - ! clr sky trhr(0) - ! BEGIN AMIP - AIJ(I,J,IJ_SWDCLS) = AIJ(I,J,IJ_SWDCLS) + SRDFLB(1)& - *COSZ2(I,J) - AIJ(I,J,IJ_SWNCLS) = AIJ(I,J,IJ_SWNCLS) + SRNFLB(1)& - *COSZ2(I,J) - AIJ(I,J,IJ_LWDCLS) = AIJ(I,J,IJ_LWDCLS) + TRDFLB(1) - AIJ(I,J,IJ_SWNCLT) = AIJ(I,J,IJ_SWNCLT) & - + SRNFLB(LM+LM_REQ+1)*COSZ2(I,J) - AIJ(I,J,IJ_LWNCLT) = AIJ(I,J,IJ_LWNCLT) & - + TRNFLB(LM+LM_REQ+1) - ! END AMIP -#ifdef CFMIP3_SUBDD - ! SW upward flux at TOA, Csky - !swutcs(i,j)=sruflb(lm)*csz2 - swutcs(i,j) = SRUFLB(lm)*cosz2(i,j) - ! SW downward flux at SFC, Csky - swdcls(i,j) = SRDFLB(1)*cosz2(i,j) - ! SW upward flux at SFC, Csky - swucls(i,j) = SRUFLB(1)*cosz2(i,j) -#endif - ENDIF - FTAUC = 1. - ! default : turn on cloud tau - - - !**** 2nd Optional calculation of CRF using a clear sky calc. without aerosols and Ox - IF ( cloud_rad_forc==2 ) THEN - FTAUC = 0. - ! turn off cloud tau (tauic +tauwc) - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - ! Including turn off of aerosols and Ox during crf calc.+++++++++++++++++++ -#ifdef TRACERS_SPECIAL_Shindell - use_o3_ref = 1 - use_tracer_chem(1) = 0 !turns off ozone -#endif - FSTOPX( : ) = 0 - !turns off aerosol tracers - FTTOPX( : ) = 0 - CALL RCOMPX - ! cloud_rad_forc=2 : clr sky - FSTOPX( : ) = onoff_aer - !turns on aerosol tracers, if requested - FTTOPX( : ) = onoff_aer - ! -#ifdef TRACERS_SPECIAL_Shindell - use_o3_ref = 0 - use_tracer_chem(1) = onoff_chem*Lmax_rad_O3 - ! turns on ozone tracers -#endif - SNFSCRF2(I,J) = SRNFLB(LM+LM_REQ+1) - ! always TOA - TNFSCRF2(I,J) = TRNFLB(LM+LM_REQ+1) - ! always TOA - ENDIF - FTAUC = 1. - ! default : turn on cloud tau - - IF ( cloud_rad_forc>0 ) THEN - !**** all sky calc. without aerosol - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - FSTOPX( : ) = 0 - !turns off aerosol tracers - FTTOPX( : ) = 0 - CALL RCOMPX - ! all sky - FSTOPX( : ) = onoff_aer - !turns on aerosol tracers, if requested - FTTOPX( : ) = onoff_aer - ! - - SNFS_AS_noA(I,J) = SRNFLB(LM+LM_REQ+1) - ! always TOA - TNFS_AS_noA(I,J) = TRNFLB(LM+LM_REQ+1) - ! always TOA - - !**** clear sky calc. without aerosol - FTAUC = 0. - ! turn off cloud tau (tauic +tauwc) - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - FSTOPX( : ) = 0 - !turns off aerosol tracers - FTTOPX( : ) = 0 - CALL RCOMPX - ! clr sky - FSTOPX( : ) = onoff_aer - !turns on aerosol tracers, if requested - FTTOPX( : ) = onoff_aer - ! - - SNFS_CS_noA(I,J) = SRNFLB(LM+LM_REQ+1) - ! always TOA - TNFS_CS_noA(I,J) = TRNFLB(LM+LM_REQ+1) - ! always TOA - FTAUC = 1. - ! default : turn on cloud tau - ENDIF - - !**** Optional calculation of the impact of NINT aerosols - IF ( aer_rad_forc>0 ) THEN - !**** first, separate aerosols - DO N = 1, 8 - tmpS(N) = FS8OPX(N) - tmpT(N) = FT8OPX(N) - FS8OPX(N) = 0. - FT8OPX(N) = 0. - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX - ! aer_rad_forc>0 : no aerosol N - SNFSAERRF(N,I,J) = SRNFLB(LM+LM_REQ+1) - ! TOA - TNFSAERRF(N,I,J) = TRNFLB(LM+LM_REQ+1) - ! TOA - SNFSAERRF(N+8,I,J) = SRNFLB(1) - ! SURF - TNFSAERRF(N+8,I,J) = TRNFLB(1) - ! SURF - FS8OPX(N) = tmpS(N) - FT8OPX(N) = tmpT(N) - ENDDO - !**** second, net aerosols - tmpS( : ) = FS8OPX( : ) - tmpT( : ) = FT8OPX( : ) - FS8OPX( : ) = 0. - FT8OPX( : ) = 0. - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - CALL RCOMPX ! aer_rad_forc>0 : no aerosols - SNFSAERRF(17,I,J) = SRNFLB(LM+LM_REQ+1) - ! TOA - TNFSAERRF(17,I,J) = TRNFLB(LM+LM_REQ+1) - ! TOA - SNFSAERRF(18,I,J) = SRNFLB(1) - ! SURF - TNFSAERRF(18,I,J) = TRNFLB(1) - ! SURF - FS8OPX( : ) = tmpS( : ) - FT8OPX( : ) = tmpT( : ) - ENDIF - ENDIF - ! moddrf=0 - - !**** End of initial computations for optional forcing diagnostics - - !**** Localize fields that are modified by RCOMPX - kdeliq(1:LM, 1:4) = kliq(1:LM, 1:4,i,j) - - !***************************************************** - ! Main RADIATIVE computations, SOLAR and THERM(A)L - CALL RCOMPX - !***************************************************** - -#ifdef CACHED_SUBDD - CO2out(1:LM, i,j) = CO2outCol(1:LM) -#endif -#ifdef GCC_UNCOUPLE_RAD_CONCEN - ! Put back the actual amount of CO2 to fulgas - FULGAS(2) = GCCco2_fulgas_now -#endif -#if (defined TRACERS_AEROSOLS_Koch) || (defined TRACERS_DUST) ||\ - (defined TRACERS_MINERALS) || (defined TRACERS_AMP) ||\ - (defined TRACERS_TOMAS) || (defined TRACERS_AEROSOLS_SEASALT) - - !**** Save optical depth diags - nsub_ntrix = 0 - DO n = 1, nraero_aod - SELECT CASE (TRNAME(NTRIX_AOD(n))) - CASE ('Clay','ClayIlli','ClayKaol','ClaySmec', & - &'ClayCalc','ClayQuar','ClayFeld','ClayHema', & - &'ClayGyps','ClayIlHe','ClayKaHe','ClaySmHe', & - &'ClayCaHe','ClayQuHe','ClayFeHe','ClayGyHe') - nsub_ntrix(NTRIX_AOD(n)) = nsub_ntrix(NTRIX_AOD(n))& - + 1 - - ! 3d aod - IF ( diag_aod_3d>0 .AND. diag_aod_3d<5 ) THEN - ! valid values are 1-4 - IF ( IJLT_3DAAOD(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAOD(n)) & - = taijls(i,j,1:LM, IJLT_3DAAOD(n)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) - IF ( IJLT_3DAAODCS(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODCS(n)) & - = taijls(i,j,1:LM, IJLT_3DAAODCS(n)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) & - *OPNSKY - IF ( IJLT_3DAAODDRY(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODDRY(n)) & - = taijls(i,j,1:LM, IJLT_3DAAODDRY(n)) & - + (aesqex_dry(1:LM, 6,n) & - -aesqsc_dry(1:LM, 6,n)) - IF ( IJLT_3DTAU(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAU(n)) & - = taijls(i,j,1:LM, IJLT_3DTAU(n)) & - + aesqex(1:LM, 6,n) - IF ( IJLT_3DTAUCS(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUCS(n)) & - = taijls(i,j,1:LM, IJLT_3DTAUCS(n)) & - + aesqex(1:LM, 6,n)*OPNSKY - IF ( IJLT_3DTAUDRY(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUDRY(n)) & - = taijls(i,j,1:LM, IJLT_3DTAUDRY(n)) & - + aesqex_dry(1:LM, 6,n) - ELSEIF ( diag_aod_3d<0 .AND. diag_aod_3d>-5 ) THEN - ! if negative, save total - IF ( IJLT_3DAAOD(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAOD(1)) & - = taijls(i,j,1:LM, IJLT_3DAAOD(1)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) - IF ( IJLT_3DAAODCS(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODCS(1)) & - = taijls(i,j,1:LM, IJLT_3DAAODCS(1)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) & - *OPNSKY - IF ( IJLT_3DAAODDRY(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODDRY(1)) & - = taijls(i,j,1:LM, IJLT_3DAAODDRY(1)) & - + (aesqex_dry(1:LM, 6,n) & - -aesqsc_dry(1:LM, 6,n)) - IF ( IJLT_3DTAU(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAU(1)) & - = taijls(i,j,1:LM, IJLT_3DTAU(1)) & - + aesqex(1:LM, 6,n) - IF ( IJLT_3DTAUCS(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUCS(1)) & - = taijls(i,j,1:LM, IJLT_3DTAUCS(1)) & - + aesqex(1:LM, 6,n)*OPNSKY - IF ( IJLT_3DTAUDRY(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUDRY(1)) & - = taijls(i,j,1:LM, IJLT_3DTAUDRY(1)) & - + aesqex_dry(1:LM, 6,n) - ENDIF - ! 0diag_aod_3d>-5 - - ! 2d aod, per band or just band6, depending on diag_rad - IF ( diag_rad/=1 ) THEN - IF ( IJTS_TAUSUB(1,NTRIX_AOD(n),nsub_ntrix( & - NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_TAUSUB(1,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_TAUSUB(1,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqex(1:LM, 6,n)) - IF ( IJTS_TAUSUB(2,NTRIX_AOD(n),nsub_ntrix( & - NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_TAUSUB(2,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_TAUSUB(2,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqex(1:LM, 6,n))*OPNSKY - IF ( IJTS_TAUSUB(3,NTRIX_AOD(n),nsub_ntrix( & - NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_TAUSUB(3,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_TAUSUB(3,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqex_dry(1:LM, 6,n)) - ELSE - DO kr = 1, 6 - IF ( IJTS_SQEXSUB(1,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQEXSUB(1,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQEXSUB(1,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqex(1:LM, kr,n)) - IF ( IJTS_SQEXSUB(2,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQEXSUB(2,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQEXSUB(2,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqex(1:LM, kr,n))*OPNSKY - IF ( IJTS_SQEXSUB(3,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQEXSUB(3,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQEXSUB(3,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqex_dry(1:LM, kr,n)) - IF ( IJTS_SQSCSUB(1,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQSCSUB(1,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQSCSUB(1,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqsc(1:LM, kr,n)) - IF ( IJTS_SQSCSUB(2,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQSCSUB(2,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQSCSUB(2,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqsc(1:LM, kr,n))*OPNSKY - IF ( IJTS_SQSCSUB(3,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQSCSUB(3,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQSCSUB(3,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqsc_dry(1:LM, kr,n)) - IF ( IJTS_SQCBSUB(1,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQCBSUB(1,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQCBSUB(1,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqcb(1:LM, kr,n)) & - /(SUM(aesqsc(1:LM, kr,n))+1.D-10) - IF ( IJTS_SQCBSUB(2,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQCBSUB(2,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQCBSUB(2,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqcb(1:LM, kr,n)) & - /(SUM(aesqsc(1:LM, kr,n))+1.D-10)*OPNSKY - IF ( IJTS_SQCBSUB(3,kr,NTRIX_AOD(n), & - nsub_ntrix(NTRIX_AOD(n)))>0 ) & - TAIJS(i,j,IJTS_SQCBSUB(3,kr,NTRIX_AOD(n)& - ,nsub_ntrix(NTRIX_AOD(n)))) & - = TAIJS(i,j,IJTS_SQCBSUB(3,kr, & - NTRIX_AOD(n),nsub_ntrix(NTRIX_AOD(n)))) & - + SUM(aesqcb_dry(1:LM, kr,n)) & - /(SUM(aesqsc_dry(1:LM, kr,n))+1.D-10) - ENDDO - ENDIF - CASE DEFAULT - - ! 3d aod - IF ( diag_aod_3d>0 .AND. diag_aod_3d<5 ) THEN - ! valid values are 1-4 - IF ( IJLT_3DAAOD(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAOD(n)) & - = taijls(i,j,1:LM, IJLT_3DAAOD(n)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) - IF ( IJLT_3DAAODCS(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODCS(n)) & - = taijls(i,j,1:LM, IJLT_3DAAODCS(n)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) & - *OPNSKY - IF ( IJLT_3DAAODDRY(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODDRY(n)) & - = taijls(i,j,1:LM, IJLT_3DAAODDRY(n)) & - + (aesqex_dry(1:LM, 6,n)-aesqsc(1:LM, 6,n)) - IF ( IJLT_3DTAU(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAU(n)) & - = taijls(i,j,1:LM, IJLT_3DTAU(n)) & - + aesqex(1:LM, 6,n) - IF ( IJLT_3DTAUCS(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUCS(n)) & - = taijls(i,j,1:LM, IJLT_3DTAUCS(n)) & - + aesqex(1:LM, 6,n)*OPNSKY - IF ( IJLT_3DTAUDRY(n)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUDRY(n)) & - = taijls(i,j,1:LM, IJLT_3DTAUDRY(n)) & - + aesqex_dry(1:LM, 6,n) - ELSEIF ( diag_aod_3d<0 .AND. diag_aod_3d>-5 ) THEN - ! if negative, save total - IF ( IJLT_3DAAOD(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAOD(1)) & - = taijls(i,j,1:LM, IJLT_3DAAOD(1)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) - IF ( IJLT_3DAAODCS(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODCS(1)) & - = taijls(i,j,1:LM, IJLT_3DAAODCS(1)) & - + (aesqex(1:LM, 6,n)-aesqsc(1:LM, 6,n)) & - *OPNSKY - IF ( IJLT_3DAAODDRY(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DAAODDRY(1)) & - = taijls(i,j,1:LM, IJLT_3DAAODDRY(1)) & - + (aesqex_dry(1:LM, 6,n) & - -aesqsc_dry(1:LM, 6,n)) - IF ( IJLT_3DTAU(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAU(1)) & - = taijls(i,j,1:LM, IJLT_3DTAU(1)) & - + aesqex(1:LM, 6,n) - IF ( IJLT_3DTAUCS(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUCS(1)) & - = taijls(i,j,1:LM, IJLT_3DTAUCS(1)) & - + aesqex(1:LM, 6,n)*OPNSKY - IF ( IJLT_3DTAUDRY(1)>0 ) & - taijls(i,j,1:LM, IJLT_3DTAUDRY(1)) & - = taijls(i,j,1:LM, IJLT_3DTAUDRY(1)) & - + aesqex_dry(1:LM, 6,n) - ENDIF - ! 0diag_aod_3d>-5 - - ! 2d aod, per band or just band6, depending on diag_rad - IF ( diag_rad/=1 ) THEN - IF ( IJTS_TAU(1,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_TAU(1,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_TAU(1,NTRIX_AOD(n))) & - + SUM(aesqex(1:LM, 6,n)) - IF ( IJTS_TAU(2,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_TAU(2,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_TAU(2,NTRIX_AOD(n))) & - + SUM(aesqex(1:LM, 6,n))*OPNSKY - IF ( IJTS_TAU(3,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_TAU(3,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_TAU(3,NTRIX_AOD(n))) & - + SUM(aesqex_dry(1:LM, 6,n)) - ELSE - DO kr = 1, 6 - ! print*,'SUSA diag',SUM(aesqex(1:LM, kr,n)) - IF ( IJTS_SQEX(1,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQEX(1,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQEX(1,kr,NTRIX_AOD(n))& - ) + SUM(aesqex(1:LM, kr,n)) - IF ( IJTS_SQEX(2,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQEX(2,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQEX(2,kr,NTRIX_AOD(n))& - ) + SUM(aesqex(1:LM, kr,n))*OPNSKY - IF ( IJTS_SQEX(3,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQEX(3,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQEX(3,kr,NTRIX_AOD(n))& - ) + SUM(aesqex_dry(1:LM, kr,n)) - IF ( IJTS_SQSC(1,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQSC(1,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQSC(1,kr,NTRIX_AOD(n))& - ) + SUM(aesqsc(1:LM, kr,n)) - IF ( IJTS_SQSC(2,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQSC(2,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQSC(2,kr,NTRIX_AOD(n))& - ) + SUM(aesqsc(1:LM, kr,n))*OPNSKY - IF ( IJTS_SQSC(3,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQSC(3,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQSC(3,kr,NTRIX_AOD(n))& - ) + SUM(aesqsc_dry(1:LM, kr,n)) -#ifndef TRACERS_TOMAS - IF ( IJTS_SQCB(1,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQCB(1,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQCB(1,kr,NTRIX_AOD(n))& - ) + SUM(aesqcb(1:LM, kr,n)) & - /(SUM(aesqsc(1:LM, kr,n))+1.D-10) - IF ( IJTS_SQCB(2,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQCB(2,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQCB(2,kr,NTRIX_AOD(n))& - ) + SUM(aesqcb(1:LM, kr,n)) & - /(SUM(aesqsc(1:LM, kr,n))+1.D-10) & - *OPNSKY - IF ( IJTS_SQCB(3,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQCB(3,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQCB(3,kr,NTRIX_AOD(n))& - ) + SUM(aesqcb_dry(1:LM, kr,n)) & - /(SUM(aesqsc_dry(1:LM, kr,n))+1.D-10) -#else - qcb_col(kr,n) = 0.D0 - qcb_col_dry(kr,n) = 0.D0 - DO l = 1, lm - qcb_col(kr,n) = qcb_col(kr,n) & - + aesqcb(l,kr,n)*aesqsc(l,kr,n) - qcb_col_dry(kr,n) = qcb_col(kr,n) & - + aesqcb_dry(l,kr,n)*aesqsc_dry(l,kr,n) - ENDDO - - IF ( IJTS_SQCB(1,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQCB(1,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQCB(1,kr,NTRIX_AOD(n))& - ) + qcb_col(kr,n) & - /(SUM(aesqsc(1:LM, kr,n))+1.D-10) - IF ( IJTS_SQCB(2,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQCB(2,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQCB(2,kr,NTRIX_AOD(n))& - ) + qcb_col(kr,n) & - /(SUM(aesqsc(1:LM, kr,n))+1.D-10) & - *OPNSKY - IF ( IJTS_SQCB(3,kr,NTRIX_AOD(n))>0 ) & - TAIJS(i,j,IJTS_SQCB(3,kr,NTRIX_AOD(n))) & - = TAIJS(i,j,IJTS_SQCB(3,kr,NTRIX_AOD(n))& - ) + qcb_col_dry(kr,n) & - /(SUM(aesqsc_dry(1:LM, kr,n))+1.D-10) -#endif - ENDDO - ! kr - ENDIF - ! diag_rad - ENDSELECT - ! clay or not - ENDDO - ! nraero_aod - -#endif /* Koch||DUST||MINERALS||AMP||TOMAS||SEASALT */ - - IF ( TAero_aod_diag>0 ) THEN - DO n = 1, 8 - ! 8 radiatively active aerosol tracers - DO kr = 1, 6 - ! 6 bands in the shortwave - IF ( TAero_aod_diag==2 .AND. kr/=6 ) CYCLE - ! only save band6 - AIJ(i,j,IJ_NINTAEREXT(kr,n)) & - = AIJ(i,j,IJ_NINTAEREXT(kr,n)) & - + SUM(nintaerext(1:LM, kr,n)) - AIJ(i,j,IJ_NINTAERSCA(kr,n)) & - = AIJ(i,j,IJ_NINTAERSCA(kr,n)) & - + SUM(nintaersca(1:LM, kr,n)) - AIJ(i,j,IJ_NINTAERASY(kr,n)) & - = AIJ(i,j,IJ_NINTAERASY(kr,n)) & - + SUM(nintaerasy(1:LM, kr,n) & - *nintaersca(1:LM, kr,n)) & - /(SUM(nintaersca(1:LM, kr,n))+1.D-10) - ENDDO - ! kr - ENDDO - ! n - ENDIF - - -#ifdef TRACERS_ON - IF ( nraero_aod>0 ) THEN - tau_as(i,j,1:LM, 1 : nraero_aod) & - = aesqex(1:LM, 6,1 : nraero_aod) - tau_cs(i,j,1:LM, 1 : nraero_aod) & - = aesqex(1:LM, 6,1 : nraero_aod)*OPNSKY - IF ( save_dry_aod>0 ) tau_dry(i,j,1:LM, 1 : nraero_aod) & - = aesqex_dry(1:LM, 6,1 : nraero_aod) -#ifdef CACHED_SUBDD - abstau_as(i,j,1:LM, 1 : nraero_aod) & - = (aesqex(1:LM, 6,1 : nraero_aod) & - -aesqsc(1:LM, 6,1 : nraero_aod)) - abstau_cs(i,j,1:LM, 1 : nraero_aod) & - = (aesqex(1:LM, 6,1 : nraero_aod) & - -aesqsc(1:LM, 6,1 : nraero_aod))*OPNSKY - IF ( save_dry_aod>0 ) & - abstau_dry(i,j,1:LM, 1 : nraero_aod) & - = (aesqex_dry(1:LM, 6,1 : nraero_aod) & - -aesqsc_dry(1:LM, 6,1 : nraero_aod)) -#endif /* CACHED_SUBDD */ - ENDIF -#endif /* TRACERS_ON */ - - IF ( I==IWRITE .AND. J==JWRITE ) CALL WRITER(6,ITWRITE) - CSZ2 = COSZ2(I,J) - DO L = 1, LM -#ifdef GCC_COUPLE_RAD - GCCCO2RAD_TO_CHEM(L,i,j) = GCCCO2_OUT(L) -#endif - rad_to_chem( : ,L,i,j) = chem_out(L, : ) - rad_to_chem(4,L,i,j) = chem_out(L,4)/CH4X_RADoverCHEM - DO k = 1, 4 - kliq(L,k,i,j) = kdeliq(L,k) - ! save updated flags - ENDDO - ENDDO - IF ( kradia>0 ) THEN - ! rad. forc. model; acc diagn - DO L = 1, LM + LM_REQ + 1 - AFLX_ST(L,I,J,1) = AFLX_ST(L,I,J,1) + SRUFLB(L) & - *CSZ2 - AFLX_ST(L,I,J,2) = AFLX_ST(L,I,J,2) + SRDFLB(L) & - *CSZ2 - AFLX_ST(L,I,J,3) = AFLX_ST(L,I,J,3) + TRUFLB(L) - AFLX_ST(L,I,J,4) = AFLX_ST(L,I,J,4) + TRDFLB(L) - ENDDO - IF ( kradia==1 ) THEN - tauex6 = 0. - tauex5 = 0. - tausct = 0. - taugcb = 0. - DO L = 1, LM - AFLX_ST(L,I,J,5) = AFLX_ST(L,I,J,5) & - + 1.D2*RHL(L) - tauex6 = tauex6 + SRAEXT(L,6) + SRDEXT(L,6) & - + SRVEXT(L,6) - tauex5 = tauex5 + SRAEXT(L,5) + SRDEXT(L,5) & - + SRVEXT(L,5) - tausct = tausct + SRASCT(L,6) + SRDSCT(L,6) & - + SRVSCT(L,6) - taugcb = taugcb + SRASCT(L,6)*SRAGCB(L,6) & - + SRDSCT(L,6)*SRDGCB(L,6) + SRVSCT(L,6)& - *SRVGCB(L,6) - ENDDO - AFLX_ST(LM+1,I,J,5) = AFLX_ST(LM+1,I,J,5) + tauex5 - AFLX_ST(LM+2,I,J,5) = AFLX_ST(LM+2,I,J,5) + tauex6 - AFLX_ST(LM+3,I,J,5) = AFLX_ST(LM+3,I,J,5) + tausct - AFLX_ST(LM+4,I,J,5) = AFLX_ST(LM+4,I,J,5) + taugcb - CYCLE - ENDIF - DO l = LS1_loc, lm - TCHG(l,i,j) = TCHG(l,i,j) & - + (SRFHRL(l)*csz2-srhra(l,i,j) & - +(-TRFCRL(l)-trhra(l,i,j))) & - *nrad*DTsrc*bysha*BYMA(l,i,j) - ENDDO - DO l = lm + 1, lm + lm_req - TCHG(l,i,j) = TCHG(l,i,j) & - + (SRFHRL(l)*csz2-srhra(l,i,j) & - +(-TRFCRL(l)-trhra(l,i,j))) & - *nrad*DTsrc*bysha*BYAML00(l) - ENDDO - CYCLE - ELSEIF ( kradia<0 ) THEN - ! save i/o data for frc.runs - fmp_com(i,j) = fmp ! input data - wsoil(i,j) = wearth - DO L = 1, LM - QR(L,I,J) = SHL(L) - CLDinfo(L,1,I,J) = TAUWC(L) - CLDinfo(L,2,I,J) = TAUIC(L) - CLDinfo(L,3,I,J) = SIZEIC(L) - ! sizeic=sizewc currently - ENDDO - SRHRA(0,I,J) = SRNFLB(1)*CSZ2 - ! output data (for adj frc) - TRHRA(0,I,J) = -TRNFLB(1) - DO L = 1, LM + LM_REQ - SRHRA(L,I,J) = SRFHRL(L)*CSZ2 - TRHRA(L,I,J) = -TRFCRL(L) - ENDDO - ENDIF - !**** - !**** Save relevant output in model arrays - !**** - !**** (some generalisation and coherence needed in the rad surf type calc) - FSF(1,I,J) = FSRNFG(1) - ! ocean - FSF(2,I,J) = FSRNFG(3) - ! ocean ice - FSF(3,I,J) = FSRNFG(4) - ! land ice - FSF(4,I,J) = FSRNFG(2) - ! soil - SRHR(0,I,J) = SRNFLB(1) - TRHR(0,I,J) = STBO*(POCEAN*atmocn%GTEMPR(I,J)**4+POICE* & - atmice%GTEMPR(I,J) & - **4+PLICE*atmgla%GTEMPR(I,J) & - **4+PEARTH*atmlnd%GTEMPR(I,J)**4) & - - TRNFLB(1) - TRSURF(1,I,J) = STBO*atmocn%GTEMPR(I,J)**4 - ! ocean - TRSURF(2,I,J) = STBO*atmice%GTEMPR(I,J)**4 - ! ocean ice - TRSURF(3,I,J) = STBO*atmgla%GTEMPR(I,J)**4 - ! land ice - TRSURF(4,I,J) = STBO*atmlnd%GTEMPR(I,J)**4 - ! soil - DO L = 1, LM - SRHR(L,I,J) = SRFHRL(L) - TRHR(L,I,J) = -TRFCRL(L) - ENDDO - DO LR = 1, LM_REQ - SRHRS(LR,I,J) = SRFHRL(LM+LR) - TRHRS(LR,I,J) = -TRFCRL(LM+LR) - ENDDO -#ifdef SCM - !**** possibly turn off radiative heating in atmosphere - !**** and use specified profile for thermal heating rate - !**** converting units from K/s to W/m2 - IF ( SCMopt%QRAD ) THEN - SRHR(1:LM, I,J) = 0. - TRHR(1:LM, I,J) = 0. - SRHRS(1:LM_REQ,I,J) = 0. - TRHRS(1:LM_REQ,I,J) = 0. - TRHR(1:LM, I,J) = SCMin%QRAD(1:LM)*SHA*MA(1:LM, I,J) - ENDIF - !**** possibly turn off radiative heating in atmosphere - !**** and use Beers Law for thermal heating rate as - !**** difference of net flux over layer - IF ( SCMopt%BEERSLAW ) THEN - SRHR(1:LM, I,J) = 0. - TRHR(1:LM, I,J) = 0. - SRHRS(1:LM_REQ,I,J) = 0. - TRHRS(1:LM_REQ,I,J) = 0. - ! cumulative cloud water paths * extinction coefficient - q_above(LM+1) = 0. - DO L = LM, 1, -1 - q_above(L) = q_above(L+1) & - + SCMin%BEERSLAW_KAPPA*MA(L,i,j) & - *QCL(i,j,L) - ENDDO - q_below(1) = 0. - DO L = 1, LM - q_below(L+1) = q_below(L) & - + SCMin%BEERSLAW_KAPPA*MA(L,i,j) & - *QCL(i,j,L) - ENDDO - ! net upward radiative flux at layer edges - Frad( : ) = SCMin%BEERSLAW_F0*EXP(-q_above( : )) & - + SCMin%BEERSLAW_F1*EXP(-q_below( : )) - ! radiative flux difference over each layer - TRHR(1:LM, I,J) = Frad(1:LM) - Frad(2 : LM+1) - ENDIF - !**** save radiative flux profiles for sub-daily output -#ifdef CACHED_SUBDD - TRDFLB_prof(I,J,1:LM) = TRDFLB(1:LM) - TRUFLB_prof(I,J,1:LM) = TRUFLB(1:LM) - SRDFLB_prof(I,J,1:LM) = SRDFLB(1:LM) - SRUFLB_prof(I,J,1:LM) = SRUFLB(1:LM) -#endif -#endif - !**** Save fluxes at four levels surface, P0, P1, LTROPO - ! Surface - SNFS(1,I,J) = SRNFLB(1) - TNFS(1,I,J) = TRNFLB(1) - ! P1 - SNFS(2,I,J) = SRNFLB(LM+1) - TNFS(2,I,J) = TRNFLB(LM+1) - ! P0 = TOA - SNFS(3,I,J) = SRNFLB(LM+LM_REQ+1) - TNFS(3,I,J) = TRNFLB(LM+LM_REQ+1) - ! LTROPO - SNFS(4,I,J) = SRNFLB(LTROPO(I,J)) - TNFS(4,I,J) = TRNFLB(LTROPO(I,J)) - -#ifdef TRACERS_GC - SNFS_3D(I,J,:) = SRNFLB(:) - TNFS_3D(I,J,:) = TRNFLB(:) - ! Archive total flux for diagnostis - SAVE_RF_3D(I,J,:,0,1) = SRNFLB(:) - SAVE_RF_3D(I,J,:,0,2) = TRNFLB(:) -#endif - - !**** - TRINCG(I,J) = TRDFLB(1) - BTMPW(I,J) = BTEMPW - TF - ALB(I,J,1) = SRNFLB(1)/(SRDFLB(1)+1.D-20) - ALB(I,J,2) = PLAVIS - ALB(I,J,3) = PLANIR - ALB(I,J,4) = ALBVIS - ALB(I,J,5) = ALBNIR - ALB(I,J,6) = SRRVIS - ALB(I,J,7) = SRRNIR - ALB(I,J,8) = SRAVIS - ALB(I,J,9) = SRANIR - -#ifdef TRACERS_DUST - IF ( adiurn_dust==1 ) THEN - srnflb_save(i,j,1:LM) = SRNFLB(1:LM) - trnflb_save(i,j,1:LM) = TRNFLB(1:LM) - ENDIF -#endif -#ifdef mjo_subdd - SWU_AVG(I,J) = SWU_AVG(I,J) + SRUFLB(1)*CSZ2 -#endif - - SWUS(I,J) = SRUFLB(1)*CSZ2 -#ifdef CFMIP3_SUBDD - ! SW upward flux at TOA - swut(i,j) = SRUFLB(lm)*csz2 - ! SW downward flux at TOA - swdt(i,j) = SRDFLB(lm)*csz2 -#endif - SRDN(I,J) = SRDFLB(1) - ! save total solar flux at surface - !**** SALB(I,J)=ALB(I,J,1) ! save surface albedo (pointer) - FSRDIR(I,J) = SRXVIS - ! direct visible solar at surface **coefficient - SRVISSURF(I,J) = SRDVIS - ! total visible solar at surface - DIRVIS(I,J) = SRXVIS*SRDVIS - ! direct visible solar at surface - FSRDIF(I,J) = SRDVIS*(1-SRXVIS) - ! diffuse visible solar at surface - - DIRNIR(I,J) = SRXNIR*SRDNIR - ! direct beam nir solar at surface - DIFNIR(I,J) = SRDNIR*(1-SRXNIR) - ! diffuse nir solar at surface - - !diag write(*,'(a,2i5,6e12.4)')'RAD_DRV : ', - !diag. I,J,FSRDIR(I,J),SRVISSURF(I,J),FSRDIF(I,J), - !diag. DIRNIR(I,J),SRDNIR,DIFNIR(I,J) - !**** Save clear sky/tropopause diagnostics here - AIJ(I,J,IJ_CLR_SRINCG) = AIJ(I,J,IJ_CLR_SRINCG) & - + OPNSKY*SRDFLB(1)*CSZ2 - AIJ(I,J,IJ_CLR_SRNFG) = AIJ(I,J,IJ_CLR_SRNFG) & - + OPNSKY*SRNFLB(1)*CSZ2 - AIJ(I,J,IJ_CLR_TRDNG) = AIJ(I,J,IJ_CLR_TRDNG) & - + OPNSKY*TRHR(0,I,J) - AIJ(I,J,IJ_CLR_SRUPTOA) = AIJ(I,J,IJ_CLR_SRUPTOA) & - + OPNSKY*SRUFLB(LM+LM_REQ+1)*CSZ2 - AIJ(I,J,IJ_CLR_TRUPTOA) = AIJ(I,J,IJ_CLR_TRUPTOA) & - + OPNSKY*TRUFLB(LM+LM_REQ+1) - AIJ(I,J,IJ_CLR_SRNTP) = AIJ(I,J,IJ_CLR_SRNTP) & - + OPNSKY*SRNFLB(LTROPO(I,J))*CSZ2 - AIJ(I,J,IJ_CLR_TRNTP) = AIJ(I,J,IJ_CLR_TRNTP) & - + OPNSKY*TRNFLB(LTROPO(I,J)) - AIJ(I,J,IJ_SRNTP) = AIJ(I,J,IJ_SRNTP) & - + SRNFLB(LTROPO(I,J))*CSZ2 - AIJ(I,J,IJ_TRNTP) = AIJ(I,J,IJ_TRNTP) & - + TRNFLB(LTROPO(I,J)) - AIJ(I,J,IJ_SISWD) = AIJ(I,J,IJ_SISWD) + POICE*SRDFLB(1) & - *CSZ2 - AIJ(I,J,IJ_SISWU) = AIJ(I,J,IJ_SISWU) & - + POICE*(SRDFLB(1)-FSRNFG(3))*CSZ2 - - DO IT = 1, NTYPE - CALL INC_AJ(i,j,it,J_CLRTOA, & - OPNSKY*(SRNFLB(LM+LM_REQ+1) & - *CSZ2-TRNFLB(LM+LM_REQ+1))*FTYPE(IT,I,J)) - CALL INC_AJ(i,j,it,J_CLRTRP, & - OPNSKY*(SRNFLB(LTROPO(I,J)) & - *CSZ2-TRNFLB(LTROPO(I,J)))*FTYPE(IT,I,J)) - CALL INC_AJ(i,j,it,J_TOTTRP, & - (SRNFLB(LTROPO(I,J))*CSZ2-TRNFLB & - (LTROPO(I,J)))*FTYPE(IT,I,J)) - ENDDO - CALL INC_AREG(i,j,jr,J_CLRTOA, & - OPNSKY*(SRNFLB(LM+LM_REQ+1)*CSZ2- & - TRNFLB(LM+LM_REQ+1))) - CALL INC_AREG(i,j,jr,J_CLRTRP, & - OPNSKY*(SRNFLB(LTROPO(I,J))*CSZ2- & - TRNFLB(LTROPO(I,J)))) - CALL INC_AREG(i,j,jr,J_TOTTRP, & - (SRNFLB(LTROPO(I,J))*CSZ2-TRNFLB & - (LTROPO(I,J)))) - !**** Save cloud top diagnostics here - IF ( CLDCV>0. ) THEN - AIJ(I,J,IJ_CLDTPPR) = AIJ(I,J,IJ_CLDTPPR) & - + PLB(ltopcl+1) - AIJ(I,J,IJ_CLDTPT) = AIJ(I,J,IJ_CLDTPT) & - + (TLB(ltopcl+1)-tf) - CTT(i,j) = (TLB(ltopcl+1)-tf) - CTP(i,j) = PLB(ltopcl+1) - !**** Save cloud tau=1 related diagnostics here (opt.depth=1 level) - tauup = 0. - DO L = LM, 1, -1 - taucl = TAUWC(l) + TAUIC(l) - taudn = tauup + taucl - IF ( taudn>1. ) THEN - AIJ(i,j,ij_cldcv1) = AIJ(i,j,ij_cldcv1) + 1. - wtlin = (1.-tauup)/taucl - AIJ(i,j,ij_cldt1t) = AIJ(i,j,ij_cldt1t) & - + (TLB(l+1)-tf+(TLB(l)-TLB(l+1))*wtlin) - AIJ(i,j,ij_cldt1p) = AIJ(i,j,ij_cldt1p) & - + (PLB(l+1)+(PLB(l)-PLB(l+1))*wtlin) - EXIT - ENDIF - tauup = taudn - ENDDO - ENDIF - - ENDDO - !**** - !**** END OF MAIN LOOP FOR I INDEX - !**** - - ENDDO - !**** - !**** END OF MAIN LOOP FOR J INDEX - !**** - -#ifdef mjo_subdd - swu_cnt = swu_cnt + 1. -#endif - - IF ( kradia>0 ) THEN - CALL STOPTIMER('RADIA()') - RETURN - ENDIF - !**** Stop if temperatures were out of range - !**** Now only warning messages are printed for T,Q errors - ! IF(ICKERR.GT.0) - ! call stop_model('In Radia : Temperature out of range',11) - ! IF(JCKERR.GT.0) call stop_model('In Radia : RQT out of range',11) - ! IF(KCKERR.GT.0) call stop_model('In Radia : Q<0',255) - !**** save all input data to disk if kradia<0 - ! LM+LM_REQ+1+ - ! ,(((GTEMPR(k,i,j),k=1,4),i=1,im),j=1,jm) ! (4+) - ! LM+1+3*LM+1+1+ - ! 1+1+1+1+1+ - ! 3+1+.5+.5+ - !**** output data : really needed only if kradia=2 - ! 2+1+1 - IF ( kradia<0 ) WRITE (iu_rad) itime, T, RQT, atmsrf%TSAVG, QR,& - P, CLDinfo, rsi, zsi, wsoil, & - atmsrf%WSAVG, snowi, & - atmgla%SNOW, atmlnd%SNOWE, & - snoage, fmp_com, flag_dsws, & - ltropo, atmlnd%FR_SNOW_RAD, & - dlake, flake, srhra, trhra, & - itime - ! 2(LM+LM_REQ+1) - !**** - !**** ACCUMULATE THE RADIATION DIAGNOSTICS - !**** - bydpreq( : ) = 1D0/(req_fac_d( : )*pmtop) - DO J = J_0, J_1 - DO I = I_0, IMAXJ(J) - DO l = 1, lm - CALL INC_AJL(i,j,l,jl_srhr,SRHR(L,I,J)*COSZ2(I,J)) - CALL INC_AJL(i,j,l,jl_trcr,TRHR(L,I,J)) - ENDDO - CSZ2 = COSZ2(I,J) - JR = JREG(I,J) - DO LR = 1, LM_REQ - CALL INC_ASJL(i,j,lr,3,bydpreq(lr)*SRHRS(LR,I,J)*CSZ2) - CALL INC_ASJL(i,j,lr,4,bydpreq(lr)*TRHRS(LR,I,J)) - ENDDO - DO KR = 1, NDIUPT - IF ( I==IJDD(1,KR) .AND. J==IJDD(2,KR) ) THEN -#if (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - TMP(idd_aot) = SUM(aesqex(1:LM, 6,1 : nraero_aod)) - !*OPNSKY - TMP(idd_aot2) = SUM(aesqsc(1:LM, 6,1 : nraero_aod)) - !*OPNSKY -#endif - TMP(IDD_PALB) = (1.-SNFS(3,I,J)/S0) - TMP(IDD_GALB) = (1.-ALB(I,J,1)) - TMP(IDD_ABSA) = (SNFS(3,I,J)-SRHR(0,I,J))*CSZ2 - DO INCH = 1, NRAD - IHM = 1 + (JTIME+INCH-1)*HR_IN_DAY/NDAY - IH = IHM - IF ( IH>HR_IN_DAY ) IH = IH - HR_IN_DAY - ADIURN(IDXB( : ),KR,IH) = ADIURN(IDXB( : ),KR,IH) & - + TMP(IDXB( : )) -#ifdef USE_HDIURN - IHM = IHM + (DATE-1)*HR_IN_DAY - IF ( IHM<=HR_IN_MONTH ) HDIURN(IDXB( : ),KR,IHM) & - = HDIURN(IDXB( : ),KR,IHM) + TMP(IDXB( : )) -#endif - ENDDO - ENDIF - ENDDO - - DO IT = 1, NTYPE - CALL INC_AJ(I,J,IT,J_SRINCP0,(S0*CSZ2)*FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_SRNFP0,(SNFS(3,I,J)*CSZ2) & - *FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_SRINCG, & - (SRHR(0,I,J)*CSZ2/(ALB(I,J,1)+1.D-20)) & - *FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_BRTEMP,BTMPW(I,J)*FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_TRINCG,TRINCG(I,J)*FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_HSURF,-(TNFS(3,I,J)-TNFS(1,I,J)) & - *FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_TRNFP0,-TNFS(3,I,J)*FTYPE(IT,I,J)& - ) - CALL INC_AJ(I,J,IT,J_TRNFP1,-TNFS(2,I,J)*FTYPE(IT,I,J)& - ) - CALL INC_AJ(I,J,IT,J_SRNFP1,SNFS(2,I,J) & - *CSZ2*FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,J_HATM,-(TNFS(2,I,J)-TNFS(1,I,J)) & - *FTYPE(IT,I,J)) -#ifdef HEALY_LM_DIAGS - CALL INC_AJ(I,J,IT,j_vtau,10.*-20*VTAULAT(J) & - *FTYPE(IT,I,J)) - CALL INC_AJ(I,J,IT,j_ghg,10.*ghg_totforc*FTYPE(IT,I,J)& - ) -#endif - - ENDDO - !**** Note : confusing because the types for radiation are a subset - CALL INC_AJ(I,J,ITOCEAN,J_SRNFG,(FSF(1,I,J)*CSZ2) & - *FOCEAN(I,J)*(1.-RSI(I,J))) - CALL INC_AJ(I,J,ITLAKE,J_SRNFG,(FSF(1,I,J)*CSZ2) & - *FLAKE(I,J)*(1.-RSI(I,J))) - CALL INC_AJ(I,J,ITEARTH,J_SRNFG,(FSF(4,I,J)*CSZ2) & - *FEARTH(I,J)) - CALL INC_AJ(I,J,ITLANDI,J_SRNFG,(FSF(3,I,J)*CSZ2) & - *FLICE(I,J)) - CALL INC_AJ(I,J,ITOICE,J_SRNFG,(FSF(2,I,J)*CSZ2) & - *FOCEAN(I,J)*RSI(I,J)) - CALL INC_AJ(I,J,ITLKICE,J_SRNFG,(FSF(2,I,J)*CSZ2) & - *FLAKE(I,J)*RSI(I,J)) - !**** - CALL INC_AREG(I,J,JR,J_SRINCP0,(S0*CSZ2)) - CALL INC_AREG(I,J,JR,J_SRNFP0,(SNFS(3,I,J)*CSZ2)) - CALL INC_AREG(I,J,JR,J_SRNFP1,(SNFS(2,I,J)*CSZ2)) - CALL INC_AREG(I,J,JR,J_SRINCG, & - (SRHR(0,I,J)*CSZ2/(ALB(I,J,1)+1.D-20))) - CALL INC_AREG(I,J,JR,J_HATM,-(TNFS(2,I,J)-TNFS(1,I,J))) - CALL INC_AREG(I,J,JR,J_SRNFG,(SRHR(0,I,J)*CSZ2)) - CALL INC_AREG(I,J,JR,J_HSURF,-(TNFS(3,I,J)-TNFS(1,I,J))) - CALL INC_AREG(I,J,JR,J_BRTEMP,BTMPW(I,J)) - CALL INC_AREG(I,J,JR,J_TRINCG,TRINCG(I,J)) - CALL INC_AREG(I,J,JR,J_TRNFP0,-TNFS(3,I,J)) - CALL INC_AREG(I,J,JR,J_TRNFP1,-TNFS(2,I,J)) - DO K = 2, 9 - JK = AJ_ALB_INDS(K-1) - ! accumulate 8 radiation diags. - DO IT = 1, NTYPE - CALL INC_AJ(I,J,IT,JK,(S0*CSZ2)*ALB(I,J,K) & - *FTYPE(IT,I,J)) - ENDDO - CALL INC_AREG(I,J,JR,JK,(S0*CSZ2)*ALB(I,J,K)) - ENDDO - AIJ(I,J,IJ_SRINCG) = AIJ(I,J,IJ_SRINCG) & - + (SRHR(0,I,J)*CSZ2/(ALB(I,J,1) & - +1.D-20)) - AIJ(I,J,IJ_SRNFG) = AIJ(I,J,IJ_SRNFG) & - + (SRHR(0,I,J)*CSZ2) - AIJ(I,J,IJ_BTMPW) = AIJ(I,J,IJ_BTMPW) + BTMPW(I,J) - AIJ(I,J,IJ_SRREF) = AIJ(I,J,IJ_SRREF) & - + S0*CSZ2*ALB(I,J,2) - AIJ(I,J,IJ_SRVIS) = AIJ(I,J,IJ_SRVIS) & - + S0*CSZ2*ALB(I,J,4) - AIJ(I,J,IJ_TRNFP0) = AIJ(I,J,IJ_TRNFP0) - TNFS(3,I,J) - AIJ(I,J,IJ_SRNFP0) = AIJ(I,J,IJ_SRNFP0) & - + (SNFS(3,I,J)*CSZ2) - AIJ(I,J,IJ_RNFP1) = AIJ(I,J,IJ_RNFP1) & - + (SNFS(2,I,J)*CSZ2-TNFS(2,I,J)) - AIJ(I,J,ij_srvdir) = AIJ(I,J,ij_srvdir) + FSRDIR(I,J) & - *SRVISSURF(I,J) - AIJ(I,J,IJ_SRVISSURF) = AIJ(I,J,IJ_SRVISSURF) & - + SRVISSURF(I,J) -#ifdef mjo_subdd - OLR_ACC(I,J) = OLR_ACC(I,J) - TNFS(3,I,J) -#endif - !**** CRF diags if required - IF ( moddrf==0 ) THEN - IF ( cloud_rad_forc>0 ) THEN - ! CRF diagnostics - AIJ(I,J,IJ_SWCRF) = AIJ(I,J,IJ_SWCRF) & - + (SNFS(3,I,J)-SNFSCRF(I,J))*CSZ2 - AIJ(I,J,IJ_LWCRF) = AIJ(I,J,IJ_LWCRF) & - - (TNFS(3,I,J)-TNFSCRF(I,J)) - ENDIF - IF ( cloud_rad_forc==2 ) THEN - ! CRF diagnostics without aerosols and Ox - AIJ(I,J,IJ_SWCRF2) = AIJ(I,J,IJ_SWCRF2) & - + (SNFS(3,I,J)-SNFSCRF2(I,J))*CSZ2 - AIJ(I,J,IJ_LWCRF2) = AIJ(I,J,IJ_LWCRF2) & - - (TNFS(3,I,J)-TNFSCRF2(I,J)) - ENDIF - - !**** AERRF diags if required - IF ( aer_rad_forc>0 ) THEN - DO N = 1, 8 - AIJ(I,J,IJ_SWAERRF+N-1) & - = AIJ(I,J,IJ_SWAERRF+N-1) & - + (SNFS(3,I,J)-SNFSAERRF(N,I,J))*CSZ2 - AIJ(I,J,IJ_LWAERRF+N-1) & - = AIJ(I,J,IJ_LWAERRF+N-1) & - - (TNFS(3,I,J)-TNFSAERRF(N,I,J)) - AIJ(I,J,IJ_SWAERSRF+N-1) & - = AIJ(I,J,IJ_SWAERSRF+N-1) & - + (SNFS(1,I,J)-SNFSAERRF(N+8,I,J))*CSZ2 - AIJ(I,J,IJ_LWAERSRF+N-1) & - = AIJ(I,J,IJ_LWAERSRF+N-1) & - - (TNFS(1,I,J)-TNFSAERRF(N+8,I,J)) - ENDDO - AIJ(I,J,IJ_SWAERRFNT) = AIJ(I,J,IJ_SWAERRFNT) & - + (SNFS(3,I,J)-SNFSAERRF(17,I,J))*CSZ2 - AIJ(I,J,IJ_LWAERRFNT) = AIJ(I,J,IJ_LWAERRFNT) & - - (TNFS(3,I,J)-TNFSAERRF(17,I,J)) - AIJ(I,J,IJ_SWAERSRFNT) = AIJ(I,J,IJ_SWAERSRFNT) & - + (SNFS(1,I,J)-SNFSAERRF(18,I,J))*CSZ2 - AIJ(I,J,IJ_LWAERSRFNT) = AIJ(I,J,IJ_LWAERSRFNT) & - - (TNFS(1,I,J)-TNFSAERRF(18,I,J)) - ENDIF - - !***** Clear Sky and All Sky TOA Forcing without aerosol - AIJ(I,J,IJ_SW_AS_noA) = AIJ(I,J,IJ_SW_AS_noA) & - + (SNFS(3,I,J)-SNFS_AS_noA(I,J))*CSZ2 - AIJ(I,J,IJ_LW_AS_noA) = AIJ(I,J,IJ_LW_AS_noA) & - - (TNFS(3,I,J)-TNFS_AS_noA(I,J)) - AIJ(I,J,IJ_SW_CS_noA) = AIJ(I,J,IJ_SW_CS_noA) & - + (SNFS(3,I,J)-SNFS_CS_noA(I,J))*CSZ2 - AIJ(I,J,IJ_LW_CS_noA) = AIJ(I,J,IJ_LW_CS_noA) & - - (TNFS(3,I,J)-TNFS_CS_noA(I,J)) - - -#ifdef TRACERS_GC - !**** Generic diagnostics for radiative forcing calculations - !**** Depending on whether tracers radiative interaction is turned on, - !**** diagnostic sign changes (for aerosols) -! rsign_aer = 1. - rsign_chem = -1. -! IF ( rad_interact_aer>0 ) rsign_aer = -1. -! !**** define SNFS/TNFS level (TOA/TROPO) for calculating forcing -! LFRC = 3 ! TOA -! IF ( rad_forc_lev>0 ) LFRC = 4 - - ! TOA - SAVE_RF(I,J,5,1) = rsign_chem*(SNFST_o3ref(2,I,J)-SNFS(3,I,J))*CSZ2 ! SW - SAVE_RF(I,J,5,2) = -rsign_chem*(TNFST_o3ref(2,I,J)-TNFS(3,I,J)) ! LW - ! Topopause - SAVE_RF_TP(I,J,5,1) = rsign_chem*(SNFST_o3ref(1,I,J)-SNFS(4,I,J))*CSZ2 ! SW - SAVE_RF_TP(I,J,5,2) = -rsign_chem*(TNFST_o3ref(1,I,J)-TNFS(4,I,J)) ! LW - ! Whole atmosphere - SAVE_RF_3D(I,J,:,5,1) = rsign_chem*(SNFS_3D_pert(I,J,:,5)-SNFS_3D(I,J,:))*CSZ2 ! SW - SAVE_RF_3D(I,J,:,5,2) = -rsign_chem*(TNFS_3D_pert(I,J,:,5)-TNFS_3D(I,J,:)) ! LW - -#endif - -#if (defined TRACERS_AEROSOLS_Koch) || (defined TRACERS_DUST) ||\ - (defined TRACERS_SPECIAL_Shindell) || (defined TRACERS_MINERALS) ||\ - (defined TRACERS_AMP) || (defined TRACERS_TOMAS) ||\ - (defined TRACERS_AEROSOLS_SEASALT) - !**** Generic diagnostics for radiative forcing calculations - !**** Depending on whether tracers radiative interaction is turned on, - !**** diagnostic sign changes (for aerosols) - rsign_aer = 1. - rsign_chem = -1. - IF ( rad_interact_aer>0 ) rsign_aer = -1. - !**** define SNFS/TNFS level (TOA/TROPO) for calculating forcing - LFRC = 3 ! TOA - IF ( rad_forc_lev>0 ) LFRC = 4 - ! TROPOPAUSE -#ifdef BC_ALB - IF ( IJTS_ALB(1)>0 .AND. bc_snow_present(i,j) .AND. & - csz2>0. ) THEN - TAIJS(I,J,ijts_sunlit_snow) & - = TAIJS(I,J,ijts_sunlit_snow) + 1. - TAIJS(I,J,IJTS_ALB(1)) = TAIJS(I,J,IJTS_ALB(1)) & - + dALBsnBC(I,J) - ! + 100.d0*(ALBNBC(I,J)-ALB(I,J,1)) - ENDIF - IF ( IJTS_ALB(2)>0 ) TAIJS(i,j,IJTS_ALB(2)) & - = TAIJS(i,j,IJTS_ALB(2)) & - + (SNFS(3,I,J)-NFSNBC(I,J))*CSZ2 -#endif /* BC_ALB */ - ! .......... - ! accumulation of forcings for tracers for which nraero_rf fields are - ! defined - ! .......... - nsub_ntrix = 0 - DO n = 1, nraero_rf - SELECT CASE (TRNAME(NTRIX_RF(n))) - CASE ('Clay','ClayIlli','ClayKaol','ClaySmec', & - &'ClayCalc','ClayQuar','ClayFeld','ClayHema', & - &'ClayGyps','ClayIlHe','ClayKaHe','ClaySmHe', & - &'ClayCaHe','ClayQuHe','ClayFeHe','ClayGyHe') - nsub_ntrix(NTRIX_RF(n)) & - = nsub_ntrix(NTRIX_RF(n)) + 1 - ! shortwave forcing (TOA or TROPO) of Clay sub size classes - IF ( IJTS_FCSUB(1,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(1,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(1,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - + rsign_aer*(snfst(2,n,i,j)-snfs(lfrc,i,j))& - *csz2 - ! longwave forcing (TOA or TROPO) of Clay size sub classes - IF ( IJTS_FCSUB(2,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(2,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(2,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - - rsign_aer*(tnfst(2,n,i,j)-tnfs(lfrc,i,j)) - ! shortwave forcing (TOA or TROPO) clear sky of Clay sub size classes - IF ( IJTS_FCSUB(5,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(5,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(5,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - + rsign_aer*(snfst(2,n,i,j)-snfs(lfrc,i,j))& - *csz2*(1.D0-cfrac(i,j)) - ! longwave forcing (TOA or TROPO) clear sky of Clay sub size classes - IF ( IJTS_FCSUB(6,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(6,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(6,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - - rsign_aer*(tnfst(2,n,i,j)-tnfs(lfrc,i,j))& - *(1.D0-cfrac(i,j)) - ! shortwave forcing at surface (if required) of Clay sub size classes - IF ( IJTS_FCSUB(3,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(3,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(3,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - + rsign_aer*(snfst(1,n,i,j)-snfs(1,i,j)) & - *csz2 - ! longwave forcing at surface (if required) of Clay sub size classes - IF ( IJTS_FCSUB(4,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(4,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(4,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - - rsign_aer*(tnfst(1,n,i,j)-tnfs(1,i,j)) - ! shortwave forcing at surface clear sky (if required) of Clay sub size classes - IF ( IJTS_FCSUB(7,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(7,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(7,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - + rsign_aer*(snfst(1,n,i,j)-snfs(1,i,j)) & - *csz2*(1.D0-cfrac(i,j)) - ! longwave forcing at surface clear sky (if required) of Clay sub size classes - IF ( IJTS_FCSUB(8,NTRIX_RF(n),nsub_ntrix( & - NTRIX_RF(n)))>0 ) & - TAIJS(i,j,IJTS_FCSUB(8,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - = TAIJS(i,j,IJTS_FCSUB(8,NTRIX_RF(n), & - nsub_ntrix(NTRIX_RF(n)))) & - - rsign_aer*(tnfst(1,n,i,j)-tnfs(1,i,j)) & - *(1.D0-cfrac(i,j)) - CASE DEFAULT - SELECT CASE (TRNAME(NTRIX_RF(n))) - CASE ('seasalt2') - CYCLE - ENDSELECT - ! shortwave forcing (TOA or TROPO) - IF ( IJTS_FC(1,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(1,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(1,NTRIX_RF(n))) & - + rsign_aer*(SNFST(2,N,I,J)-SNFS(LFRC,I,J))& - *CSZ2 - ! longwave forcing (TOA or TROPO) - IF ( IJTS_FC(2,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(2,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(2,NTRIX_RF(n))) & - - rsign_aer*(TNFST(2,N,I,J)-TNFS(LFRC,I,J)) - ! shortwave forcing (TOA or TROPO) clear sky - IF ( IJTS_FC(5,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(5,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(5,NTRIX_RF(n))) & - + rsign_aer*(SNFST(2,N,I,J)-SNFS(LFRC,I,J))& - *CSZ2*(1.D0-CFRAC(I,J)) - ! longwave forcing (TOA or TROPO) clear sky - IF ( IJTS_FC(6,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(6,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(6,NTRIX_RF(n))) & - - rsign_aer*(TNFST(2,N,I,J)-TNFS(LFRC,I,J))& - *(1.D0-CFRAC(I,J)) - ! shortwave forcing at surface (if required) - IF ( IJTS_FC(3,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(3,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(3,NTRIX_RF(n))) & - + rsign_aer*(SNFST(1,N,I,J)-SNFS(1,I,J)) & - *CSZ2 - ! longwave forcing at surface (if required) - IF ( IJTS_FC(4,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(4,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(4,NTRIX_RF(n))) & - - rsign_aer*(TNFST(1,N,I,J)-TNFS(1,I,J)) - ! shortwave forcing at surface clear sky (if required) - IF ( IJTS_FC(7,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(7,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(7,NTRIX_RF(n))) & - + rsign_aer*(SNFST(1,N,I,J)-SNFS(1,I,J)) & - *CSZ2*(1.D0-CFRAC(I,J)) - ! longwave forcing at surface clear sky (if required) - IF ( IJTS_FC(8,NTRIX_RF(n))>0 ) & - TAIJS(i,j,IJTS_FC(8,NTRIX_RF(n))) & - = TAIJS(i,j,IJTS_FC(8,NTRIX_RF(n))) & - - rsign_aer*(TNFST(1,N,I,J)-TNFS(1,I,J)) & - *(1.D0-CFRAC(I,J)) - ENDSELECT - ENDDO - ! n=1,nraero_rf - - ! .......... - ! accumulation of forcings for special case ozone (nraero_rf fields - ! not defined) Warning : indicies used differently, since we don't - ! need CS or Surface, but are doing both TOA and Ltropo : - ! .......... - IF ( n_Ox>0 ) THEN - ! ------ main Ox tracer ------- - ! shortwave forcing at tropopause - IF ( IJTS_FC(1,n_Ox)>0 ) TAIJS(i,j,IJTS_FC(1,n_Ox))& - = TAIJS(i,j,IJTS_FC(1,n_Ox)) & - + rsign_chem*(SNFST_o3ref(1,I,J)-SNFS(4,I,J)& - )*CSZ2 - ! longwave forcing at tropopause - IF ( IJTS_FC(2,n_Ox)>0 ) TAIJS(i,j,IJTS_FC(2,n_Ox))& - = TAIJS(i,j,IJTS_FC(2,n_Ox)) & - - rsign_chem*(TNFST_o3ref(1,I,J)-TNFS(4,I,J)& - ) - ! shortwave forcing at TOA - IF ( IJTS_FC(3,n_Ox)>0 ) TAIJS(i,j,IJTS_FC(3,n_Ox))& - = TAIJS(i,j,IJTS_FC(3,n_Ox)) & - + rsign_chem*(SNFST_o3ref(2,I,J)-SNFS(3,I,J)& - )*CSZ2 - ! longwave forcing at TOA - IF ( IJTS_FC(4,n_Ox)>0 ) TAIJS(i,j,IJTS_FC(4,n_Ox))& - = TAIJS(i,j,IJTS_FC(4,n_Ox)) & - - rsign_chem*(TNFST_o3ref(2,I,J)-TNFS(3,I,J)& - ) - ENDIF -#ifdef AUXILIARY_OX_RADF - ! shortwave forcing at tropopause - -#ifdef AUX_OX_RADF_TROP - IF ( IJTS_AUXFC(1)>0 ) TAIJS(i,j,IJTS_AUXFC(1)) & - = TAIJS(i,j,IJTS_AUXFC(1)) & - + rsign_chem*(SNFST_o3ref(5,I,J) & - -SNFST_o3ref(3,I,J))*CSZ2 -#else - IF ( IJTS_AUXFC(1)>0 ) TAIJS(i,j,IJTS_AUXFC(1)) & - = TAIJS(i,j,IJTS_AUXFC(1)) & - + rsign_chem*(SNFST_o3ref(1,I,J) & - -SNFST_o3ref(3,I,J))*CSZ2 -#endif - ! longwave forcing at tropopause -#ifdef AUX_OX_RADF_TROP - IF ( IJTS_AUXFC(2)>0 ) TAIJS(i,j,IJTS_AUXFC(2)) & - = TAIJS(i,j,IJTS_AUXFC(2)) & - - rsign_chem*(TNFST_o3ref(5,I,J) & - -TNFST_o3ref(3,I,J)) -#else - IF ( IJTS_AUXFC(2)>0 ) TAIJS(i,j,IJTS_AUXFC(2)) & - = TAIJS(i,j,IJTS_AUXFC(2)) & - - rsign_chem*(TNFST_o3ref(1,I,J) & - -TNFST_o3ref(3,I,J)) -#endif - ! shortwave forcing at TOA - IF ( IJTS_AUXFC(3)>0 ) TAIJS(i,j,IJTS_AUXFC(3)) & - = TAIJS(i,j,IJTS_AUXFC(3)) & - + rsign_chem*(SNFST_o3ref(2,I,J) & - -SNFST_o3ref(4,I,J))*CSZ2 - ! longwave forcing at TOA - IF ( IJTS_AUXFC(4)>0 ) TAIJS(i,j,IJTS_AUXFC(4)) & - = TAIJS(i,j,IJTS_AUXFC(4)) & - - rsign_chem*(TNFST_o3ref(2,I,J) & - -TNFST_o3ref(4,I,J)) -#endif /* AUXILIARY_OX_RADF */ -#if (defined SHINDELL_STRAT_EXTRA) &(defined ACCMIP_LIKE_DIAGS) - ! ------ diag stratOx tracer ------- - ! note for now for this diag, there is a failsafe that stops model - ! if clim_interact_chem .le. 0 when the below would be wrong : - ! shortwave forcing at tropopause - IF ( IJTS_FC(1,n_stratOx)>0 ) & - TAIJS(i,j,IJTS_FC(1,n_stratOx)) & - = TAIJS(i,j,IJTS_FC(1,n_stratOx)) & - + rsign_chem*(SNFST_o3ref(1,I,J) & - -SNFST_stratOx(1,I,J))*CSZ2 - ! longwave forcing at tropopause - IF ( IJTS_FC(2,n_stratOx)>0 ) & - TAIJS(i,j,IJTS_FC(2,n_stratOx)) & - = TAIJS(i,j,IJTS_FC(2,n_stratOx)) & - - rsign_chem*(TNFST_o3ref(1,I,J) & - -TNFST_stratOx(1,I,J)) - ! shortwave forcing at TOA - IF ( IJTS_FC(3,n_stratOx)>0 ) & - TAIJS(i,j,IJTS_FC(3,n_stratOx)) & - = TAIJS(i,j,IJTS_FC(3,n_stratOx)) & - + rsign_chem*(SNFST_o3ref(2,I,J) & - -SNFST_stratOx(2,I,J))*CSZ2 - ! longwave forcing at TOA - IF ( IJTS_FC(4,n_stratOx)>0 ) & - TAIJS(i,j,IJTS_FC(4,n_stratOx)) & - = TAIJS(i,j,IJTS_FC(4,n_stratOx)) & - - rsign_chem*(TNFST_o3ref(2,I,J) & - -TNFST_stratOx(2,I,J)) -#endif /* SHINDELL_STRAT_EXTRA &ACCMIP_LIKE_DIAGS*/ -#endif /* any of various tracer groups defined */ - -#ifdef TRACERS_GC - !============================================ - ! Methane, N2O, CFC11 and CFC12 - !============================================ - DO nf = 1, 4 - - ! TOA - SAVE_RF(I,J,nf,1) = (SNFS(3,I,J)-SNFS_ghg(nf,I,J))*CSZ2 ! SW - SAVE_RF(I,J,nf,2) = (TNFS_ghg(nf,I,J)-TNFS(3,I,J)) ! LW - - IF ( IJ_FCGHG(1,nf)>0 ) & - AIJ(i,j,IJ_FCGHG(1,nf)) = AIJ(i,j,IJ_FCGHG(1,nf)) & - + (SNFS(3,I,J)-SNFS_ghg(nf,I,J))*CSZ2 - IF ( IJ_FCGHG(2,nf)>0 ) & - AIJ(i,j,IJ_FCGHG(2,nf)) = AIJ(i,j,IJ_FCGHG(2,nf)) & - + (TNFS_ghg(nf,I,J)-TNFS(3,I,J)) - - ! Tropopause - SAVE_RF_TP(I,J,nf,1) = (SNFS(4,I,J)-SNFS_ghg_tp(nf,I,J))*CSZ2 ! SW - SAVE_RF_TP(I,J,nf,2) = (TNFS_ghg_tp(nf,I,J)-TNFS(4,I,J)) ! LW - - ! Whole Atmosphere - SAVE_RF_3D(I,J,:,nf,1) = (SNFS_3D(I,J,:)-SNFS_3D_pert(I,J,:,nf))*CSZ2 ! SW - SAVE_RF_3D(I,J,:,nf,2) = (TNFS_3D_pert(I,J,:,nf)-TNFS_3D(I,J,:)) ! LW - - ENDDO - -#endif - -#ifdef ACCMIP_LIKE_DIAGS -#ifndef SKIP_ACCMIP_GHG_RADF_DIAGS - DO nf = 1, 4 - ! CH4, N2O, CFC11, and CFC12 : - ! shortwave GHG forcing at TOA - IF ( IJ_FCGHG(1,nf)>0 ) AIJ(i,j,IJ_FCGHG(1,nf)) & - = AIJ(i,j,IJ_FCGHG(1,nf)) & - + (SNFS(3,I,J)-SNFS_ghg(nf,I,J))*CSZ2 - ! longwave GHG forcing at TOA - IF ( IJ_FCGHG(2,nf)>0 ) AIJ(i,j,IJ_FCGHG(2,nf)) & - = AIJ(i,j,IJ_FCGHG(2,nf)) & - + (TNFS_ghg(nf,I,J)-TNFS(3,I,J)) - ENDDO -#endif /* NOT DEFINED SKIP_ACCMIP_GHG_RADF_DIAGS */ -#endif /* ACCMIP_LIKE_DIAGS */ - -#ifdef CACHED_SUBDD -#if (defined TRACERS_AEROSOLS_Koch) || (defined TRACERS_DUST) ||\ - (defined TRACERS_SPECIAL_Shindell) || (defined TRACERS_MINERALS) ||\ - (defined TRACERS_AMP) || (defined TRACERS_TOMAS) ||\ - (defined TRACERS_AEROSOLS_SEASALT) - IF ( nraero_rf>0 ) THEN - swfrc(i,j,1 : nraero_rf) & - = rsign_aer*(SNFST(2,1 : nraero_rf,I,J) & - -SNFS(LFRC,I,J))*CSZ2 - lwfrc(i,j,1 : nraero_rf) & - = -rsign_aer*(TNFST(2,1 : nraero_rf,I,J) & - -TNFS(LFRC,I,J)) - ENDIF -#endif /* any of various tracer groups defined */ -#endif /* CACHED_SUBDD */ - - ENDIF - ENDDO - ENDDO - -#ifdef mjo_subdd - OLR_cnt = OLR_cnt + 1. -#endif - - DO J = J_0, J_1 - DO I = I_0, I_1 - DO L = 1, LM - AIJL(i,j,l,IJL_RC) = AIJL(i,j,l,IJL_RC) & - + (SRHR(L,I,J)*COSZ2(I,J) & - +TRHR(L,I,J)) -#ifdef mjo_subdd - SWHR(I,J,L) = SWHR(I,J,L) + SRHR(L,I,J)*COSZ2(I,J) & - *bysha*BYMA(L,I,J) - LWHR(I,J,L) = LWHR(I,J,L) + TRHR(L,I,J) & - *bysha*BYMA(L,I,J) -#endif - ENDDO - ENDDO - ENDDO -#ifdef mjo_subdd - SWHR_cnt = SWHR_cnt + 1 - LWHR_cnt = LWHR_cnt + 1 -#endif - -#ifdef CACHED_SUBDD - DO k = 1, subdd_ngroups - subdd => SUBDD_GROUPS(k) - subdd%NACC(subdd%SUBDD_PERIOD,sched_rad) & - = subdd%NACC(subdd%SUBDD_PERIOD,sched_rad) + 1 - ENDDO - !**** - !**** Collect some high-frequency outputs - !**** - CALL FIND_GROUPS('rijh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('olrrad') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = tnfs(3,i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('olrcs') - IF ( cloud_rad_forc<=0. ) CALL STOP_MODEL( & - &'diagnostic olrcs needs cloud_rad_forc>0',255) - CALL INC_SUBDD(subdd,k,TNFSCRF) - CASE ('lwds') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = TRHR(0,i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('lwdscs') - IF ( cloud_rad_forc<=0. ) CALL STOP_MODEL( & - &'diagnostic lwdscs needs cloud_rad_forc>0',255) - CALL INC_SUBDD(subdd,k,lwdncs) - CASE ('lwus') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = TRHR(0,i,j) + tnfs(1,i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('swus') - CALL INC_SUBDD(subdd,k,SWUS) - CASE ('swds') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SRDN(i,j)*cosz2(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('swdf') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = FSRDIF(i,j) + DIFNIR(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('swtoa') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = snfs(3,i,j)*cosz2(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - !Net solar flux at surface : - CASE ('swns') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = snfs(1,i,j)*cosz2(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - !Net Longwave flux at surface : - CASE ('lwns') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = tnfs(1,i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('totcld') - CALL INC_SUBDD(subdd,k,cfrac) - CASE ('totcld_diag') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - CALL GET_CLD_OVERLAP(lm,CLDSS( : ,i,j), & - CLDMCL=CLDMC( : ,i,j),CLDTOT=sddarr(i,j)) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('cldss_2d') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - CALL GET_CLD_OVERLAP(lm,CLDSS( : ,i,j), & - CLDSS=sddarr(i,j)) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('cldmc_2d') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - CALL GET_CLD_OVERLAP(lm,CLDSS( : ,i,j), & - CLDMCL=CLDMC( : ,i,j),CLDMC=sddarr(i,j)) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('wtrcld') - CALL INC_SUBDD(subdd,k,WTRCLD) - CASE ('icecld') - CALL INC_SUBDD(subdd,k,ICECLD) - CASE ('cod') - CALL INC_SUBDD(subdd,k,TAUSUMW) - CASE ('cid') - CALL INC_SUBDD(subdd,k,TAUSUMI) - CASE ('ctp') - CALL INC_SUBDD(subdd,k,CTP) - CASE ('ctt') - CALL INC_SUBDD(subdd,k,CTT) -#ifdef CFMIP3_SUBDD - CASE ('rtmt') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = (snfs(3,i,j)*cosz2(i,j)) & - - tnfs(2,i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('swut') - CALL INC_SUBDD(subdd,k,swut) - CASE ('swutcs') - CALL INC_SUBDD(subdd,k,swutcs) - CASE ('clwvi') - CALL INC_SUBDD(subdd,k,cfmip_twp) - CASE ('swdcls') - CALL INC_SUBDD(subdd,k,swdcls) - CASE ('swucls') - CALL INC_SUBDD(subdd,k,swucls) - CASE ('swdt') - CALL INC_SUBDD(subdd,k,swdt) -#endif - ENDSELECT - - ENDDO - ENDDO - -#ifdef GCAP - CALL FIND_GROUPS('aijlh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('OPTDEPTH') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - ! Weight mean cloud optical thickness by relative 2-D area fractions - sddarr3d(i,j,l) & - = (CLDSS(l,i,j)*TAUSS(l,i,j)+CLDMC(l,i,j) & - *TAUMC(l,i,j)) & - /(CLDSS(l,i,j)+CLDMC(l,i,j)+teeny) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('CLOUD') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) & - = MIN(1.0,CLDSS3D(l,i,j)+CLDMC(l,i,j)) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('TAUCLI') - CALL INC_SUBDD(subdd,k,taui3d) - CASE ('TAUCLW') - CALL INC_SUBDD(subdd,k,tauw3d) - ENDSELECT - ENDDO - ENDDO - - CALL FIND_GROUPS('aijh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('PARDF') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = 0.82*SRVISSURF(i,j) & - *(1D0-FSRDIR(i,j))*COSZ1(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('PARDR') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = 0.82*SRVISSURF(i,j)*(FSRDIR(i,j)) & - *COSZ1(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('ALBEDO') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - ! Saves non-zero albedos for nighttime - IF ( SRDN(i,j)>0 ) SAVE_ALB(i,j) & - = 1D0 - ALB(i,j,1) - sddarr(i,j) = SAVE_ALB(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('CLDTOT') - ! totcld in standard model - CALL INC_SUBDD(subdd,k,cfrac) - CASE ('SWGDN') - ! swds in standard model - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SRDN(i,j)*cosz2(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('TO3') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_TO3(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - ENDSELECT - ENDDO - ENDDO -#endif - -#ifdef TRACERS_GC - CALL FIND_GROUPS('aijh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - - !================================================== - ! Top of the Atmosphere - !================================================== - CASE ('SW_CH4') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,1,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_CH4') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,1,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_N2O') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,2,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_N2O') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,2,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_CFC11') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,3,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_CFC11') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,3,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_CFC12') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,4,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_CFC12') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,4,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_O3') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,5,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_O3') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF(i,j,5,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - - !================================================== - ! Radiative Forcing @ Tropopause - !================================================== - CASE ('SW_CH4_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,1,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_CH4_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,1,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_N2O_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,2,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_N2O_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,2,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_CFC11_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,3,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_CFC11_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,3,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_CFC12_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,4,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_CFC12_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,4,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('SW_O3_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,5,1) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('LW_O3_TP') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_RF_TP(i,j,5,2) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - - ENDSELECT - ENDDO - ENDDO - - CALL FIND_GROUPS('rijleh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - - !================================================== - ! Whole Atmosphere Radiative Forcing - !================================================== - CASE ('SW_FLUX') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,0,1) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('LW_FLUX') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,0,2) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('SW_CH4_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,1,1) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('LW_CH4_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,1,2) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('SW_N2O_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,2,1) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('LW_N2O_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,2,2) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('SW_CFC11_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,3,1) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('LW_CFC11_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,3,2) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('SW_CFC12_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,4,1) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('LW_CFC12_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,4,2) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('SW_O3_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,5,1) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - CASE ('LW_O3_3D') - SDDARRFLX = 0. - DO l = 1, LM+LM_REQ+1 - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - SDDARRFLX(i,j,l) = SAVE_RF_3D(i,j,l,5,2) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,SDDARRFLX) - ENDSELECT - ENDDO - ENDDO - -#endif - -#ifdef GCAP - - CALL FIND_GROUPS('aijh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('PARDF') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = 0.82*SRVISSURF(i,j) & - *(1D0-FSRDIR(i,j))*COSZ1(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('PARDR') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = 0.82*SRVISSURF(i,j)*(FSRDIR(i,j)) & - *COSZ1(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('ALBEDO') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - ! Saves non-zero albedos for nighttime - IF ( SRDN(i,j)>0 ) SAVE_ALB(i,j) & - = 1D0 - ALB(i,j,1) - sddarr(i,j) = SAVE_ALB(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('CLDTOT') - ! totcld in standard model - CALL INC_SUBDD(subdd,k,cfrac) - CASE ('SWGDN') - ! swds in standard model - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SRDN(i,j)*cosz2(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('TO3') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - sddarr(i,j) = SAVE_TO3(i,j) - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr) - ENDSELECT - ENDDO - ENDDO - -#endif - - CALL FIND_GROUPS('rijlh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('MRCO2rad') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = CO2out(l,i,j) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('wtrtau') - CALL INC_SUBDD(subdd,k,wtrtau) - CASE ('icetau') - CALL INC_SUBDD(subdd,k,icetau) - ENDSELECT - ENDDO - ENDDO - -#ifdef SCM - CALL FIND_GROUPS('rijlh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('dth_sw') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = SRHR(L,I,J) & - *bysha*BYMA(L,I,J)*COSZ2(I,J)/PK(L,I,J) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('dth_lw') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = TRHR(L,I,J) & - *bysha*BYMA(L,I,J)/PK(L,I,J) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('dth_rad') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) & - = (SRHR(L,I,J)*COSZ2(I,J)+TRHR(L,I,J)) & - *bysha*BYMA(L,I,J)/PK(L,I,J) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('lwdp') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = TRDFLB_prof(i,j,l) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('lwup') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = TRUFLB_prof(i,j,l) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('swdp') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = SRDFLB_prof(i,j,l) & - *COSZ2(I,J) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - CASE ('swup') - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lmaxsubdd - sddarr3d(i,j,l) = SRUFLB_prof(i,j,l) & - *COSZ2(I,J) - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - ENDSELECT - ENDDO - ENDDO -#endif -#ifdef CFMIP3_SUBDD - CALL FIND_GROUPS('rijlh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - SELECT CASE (subdd%NAME(k)) - CASE ('cf') - CALL INC_SUBDD(subdd,k,cfmip_cf) - CASE ('qcirad') - CALL INC_SUBDD(subdd,k,cfmip_qci) - CASE ('qclrad') - CALL INC_SUBDD(subdd,k,cfmip_qcl) - ENDSELECT - ENDDO - ENDDO -#endif -#ifdef TRACERS_ON - - ! aod - DO g = 1, SIZE(sgroups) - CALL FIND_GROUPS(sgroups(g),grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - DO s = 1, SIZE(ssky) - IF ( TRIM(ssky(s))=='dry' .AND. save_dry_aod==0 ) & - CYCLE - DO a = 1, SIZE(sabs) - SELECT CASE (TRIM(ssky(s))//TRIM(sabs(a))) - CASE ('as') - sddarr4d = tau_as - CASE ('cs') - sddarr4d = tau_cs - CASE ('dry') - sddarr4d = tau_dry - CASE ('asa') - sddarr4d = abstau_as - CASE ('csa') - sddarr4d = abstau_cs - CASE ('drya') - sddarr4d = abstau_dry - CASE DEFAULT - CYCLE - ! not implemented, silently ignore - ENDSELECT - DO n = 1, nraero_aod + 1 - ! +1 for total - IF ( n<=nraero_aod ) THEN - spcname = TRIM(TRNAME(NTRIX_AOD(n))) - ELSE - spcname = '' - ENDIF - !aod - sname = TRIM(spcname)//TRIM(ssky(s)) & - //TRIM(sabs(a))//'aod' - IF ( TRIM(sgroups(g))=='taijlh' ) & - sname = TRIM(sname)//'3d' - IF ( TRIM(sname)==TRIM(subdd%NAME(k)) ) THEN - ! not select case here - IF ( n<=nraero_aod ) THEN - sddarr3d = sddarr4d( : , : , : ,n) - ELSE - sddarr3d = SUM(sddarr4d,DIM=4) - ENDIF - SELECT CASE (TRIM(sgroups(g))) - CASE ('taijh') - sddarr = SUM(sddarr3d,DIM=3) - CALL INC_SUBDD(subdd,k,sddarr) - CASE ('taijlh') - CALL INC_SUBDD(subdd,k,sddarr3d) - ENDSELECT - ENDIF - !bext (bcoef) or babs (abcoef) - IF ( TRIM(sgroups(g))=='taijlh' ) THEN - sname = TRIM(spcname)//TRIM(ssky(s)) & - //TRIM(sabs(a))//'bcoef3d' - IF ( TRIM(sname)==TRIM(subdd%NAME(k)) ) & - THEN ! not select case here - IF ( n<=nraero_aod ) THEN - sddarr3d = sddarr4d( : , : , : ,n) - ELSE - sddarr3d = SUM(sddarr4d,DIM=4) - ENDIF - DO j = j_0, j_1 - DO i = i_0, IMAXJ(j) - DO l = 1, lm - TLM(l) = T(i,j,l)*PK(l,i,j) - rho = PMID(l,i,j) & - *100./(Rgas*TLM(l)) - dz = MA(l,i,j)/rho - sddarr3d(i,j,l) & - = sddarr3d(i,j,l)/dz - ENDDO - ENDDO - ENDDO - CALL INC_SUBDD(subdd,k,sddarr3d) - ENDIF - ENDIF - ENDDO - ! n - ENDDO - ! a - ENDDO - ! s - ENDDO - ! k - ENDDO - ! igrp - ENDDO - ! g - - ! rf - CALL FIND_GROUPS('taijh',grpids,ngroups) - DO igrp = 1, ngroups - subdd => SUBDD_GROUPS(grpids(igrp)) - DO k = 1, subdd%NDIAGS - DO f = 1, SIZE(sfrc) - SELECT CASE (TRIM(sfrc(f))) - CASE ('swf') - sddarr3drf = swfrc - CASE ('lwf') - sddarr3drf = lwfrc - CASE DEFAULT - CYCLE - ! not implemented, silently ignore - ENDSELECT - DO n = 1, nraero_rf - IF ( diag_fc==2 ) THEN - spcname = TRIM(TRNAME(NTRIX_RF(n))) - ELSEIF ( diag_fc==1 ) THEN - IF ( tracers_amp ) THEN - spcname = 'AMP' - ELSEIF ( tracers_tomas ) THEN - spcname = 'TOMAS' - ELSE - spcname = 'OMA' - ENDIF - ENDIF - sname = TRIM(sfrc(f))//'_'//TRIM(spcname) - IF ( TRIM(sname)==TRIM(subdd%NAME(k)) ) & - CALL INC_SUBDD(subdd,k,sddarr3drf( : , : ,n)) - ! not select case here - ENDDO - ! n - ENDDO - ! f - ENDDO - ! k - ENDDO - ! igrp - -#endif /* TRACERS_ON */ - -#endif /* CACHED_SUBDD */ - - !**** - !**** Update radiative equilibrium temperatures - !**** - DO J = J_0, J_1 - DO I = I_0, IMAXJ(J) - DO LR = 1, LM_REQ - RQT(LR,I,J) = RQT(LR,I,J) & - + (SRHRS(LR,I,J)*COSZ2(I,J)+TRHRS(LR,I, & - J))*NRAD*DTsrc*bysha*BYAML00(lr+lm) - ENDDO - ENDDO - ENDDO - ENDIF - !**** - !**** Update other temperatures every physics time step - !**** - DO J = J_0, J_1 - DO I = I_0, IMAXJ(J) - DO L = 1, LM - T(I,J,L) = T(I,J,L) & - + (SRHR(L,I,J)*COSZ1(I,J)+TRHR(L,I,J)) & - *DTsrc*bysha*BYMA(l,i,j)/PK(L,I,J) - ENDDO - AIJ(I,J,IJ_SRINCP0) = AIJ(I,J,IJ_SRINCP0) + (S0*COSZ1(I,J)) - ENDDO - ENDDO - - !**** daily diagnostics - IH = 1 + MODELECLOCK%GETHOUR() - IHM = IH + (MODELECLOCK%GETDATE()-1)*24 - DO KR = 1, NDIUPT - I = IJDD(1,KR) - J = IJDD(2,KR) - IF ( (J>=J_0) .AND. (J<=J_1) .AND. (I>=I_0) .AND. (I<=I_1) ) & - THEN - ADIURN(IDD_ISW,KR,IH) = ADIURN(IDD_ISW,KR,IH) & - + S0*COSZ1(I,J) -#ifdef USE_HDIURN - HDIURN(IDD_ISW,KR,IHM) = HDIURN(IDD_ISW,KR,IHM) & - + S0*COSZ1(I,J) -#endif - ENDIF - ENDDO - - CALL STOPTIMER('RADIA()') -END SUBROUTINE RADIA - -SUBROUTINE RESET_SURF_FLUXES(I,J,ITYPE_OLD,ITYPE_NEW,FTYPE_ORIG, & - FTYPE_NOW) - !@sum set incident solar and upward thermal fluxes appropriately - !@+ as fractions change to conserve energy, prevent restart problems - !@auth Gavin Schmidt - USE RAD_COM, ONLY : FSF, TRSURF - IMPLICIT NONE - !@var itype_old, itype_new indices for the old type turning to new type - INTEGER, INTENT(IN) :: i, j, itype_old, itype_new - !@var ftype_orig, ftype_now original and current fracs of the 'new' type - REAL*8, INTENT(IN) :: ftype_orig, ftype_now - REAL*8 :: delf - ! change in fraction from old to new - - IF ( ((ITYPE_OLD==1 .AND. ITYPE_NEW==2) .OR. & - (ITYPE_OLD==2 .AND. ITYPE_NEW==1)) .AND. & - (FTYPE_NOW<=0. .OR. FTYPE_NOW>1.) ) THEN - WRITE (6,*) & - 'RESET_SURF_FLUXES : I, J, ITYPE_OLD, ITYPE_NEW, FTYPE_ORIG, FTYPE_NOW = ', & - I, J, ITYPE_OLD, ITYPE_NEW, FTYPE_ORIG, FTYPE_NOW - CALL STOP_MODEL('RESET_SURF_FLUXES : INCORRECT RESET',255) - ENDIF - - delf = FTYPE_NOW - FTYPE_ORIG - !**** Constrain fsf_1*ftype_1+fsf_2*ftype_2 to be constant - FSF(ITYPE_NEW,I,J) = (FSF(ITYPE_NEW,I,J)*FTYPE_ORIG+FSF(ITYPE_OLD,& - I,J)*DELF)/FTYPE_NOW - - !**** Same for upward thermal - TRSURF(ITYPE_NEW,I,J) = (TRSURF(ITYPE_NEW,I,J)*FTYPE_ORIG+TRSURF( & - ITYPE_OLD,I,J)*DELF)/FTYPE_NOW - -END SUBROUTINE RESET_SURF_FLUXES - -SUBROUTINE GHGHST(iu) - !@sum reads history for nghg well-mixed greenhouse gases - !@auth R. Ruedy - - USE DOMAIN_DECOMP_ATM, ONLY : WRITE_PARALLEL - USE RADPAR, ONLY : nghg, ghgyr1, ghgyr2, ghgam - USE RAD_COM, ONLY : ghg_yr - IMPLICIT NONE - INTEGER :: iu, n, k, nhead = 4, iyr - CHARACTER*80 title - CHARACTER(LEN=300) :: out_line - - WRITE (out_line,*) ! print header lines and first data line - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - DO n = 1, nhead + 1 - READ (iu,'(a)') title - WRITE (out_line,'(1x,a80)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - ENDDO - IF ( title(1 : 2)=='--' ) THEN ! older format - READ (iu,'(a)') title - WRITE (out_line,'(1x,a80)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - nhead = 5 - ENDIF - - !**** find range of table : ghgyr1 - ghgyr2 - READ (title,*) ghgyr1 - DO - READ (iu,'(a)',END=20) title - ENDDO -20 READ (title,*) ghgyr2 - REWIND iu ! position to data lines - DO n = 1, nhead - READ (iu,'(a)') - ENDDO - - ALLOCATE (ghgam(nghg,ghgyr2-ghgyr1+1)) - DO n = 1, ghgyr2 - ghgyr1 + 1 - READ (iu,*) iyr, (ghgam(k,n),k=1,nghg) - DO k = 1, nghg - ! replace -999. by reasonable numbers - IF ( ghgam(k,n)<0. ) ghgam(k,n) = ghgam(k,n-1) - ENDDO - IF ( ghg_yr>0 .AND. ABS(ghg_yr-iyr)<=1 ) THEN - WRITE (out_line,'(i5,6f10.4)') iyr, (ghgam(k,n),k=1,nghg) - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - ENDIF - ENDDO - WRITE (out_line,*) 'read GHG table for years', ghgyr1, ' - ', & - ghgyr2 - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) -END SUBROUTINE GHGHST - -#if defined(CUBED_SPHERE) -SUBROUTINE READ_QMA(iu,plb) - !@sum reads H2O production rates induced by CH4 (Tim Hall) - !@auth R. Ruedy - USE DOMAIN_DECOMP_ATM, ONLY : WRITE_PARALLEL - USE RAD_COM, ONLY : DH2O, jma => JM_DH2O, lat_dh2o - USE RESOLUTION, ONLY : lm - USE CONSTANT, ONLY : radian - USE TIMECONSTANTS_MOD, ONLY : DAYS_PER_YEAR - IMPLICIT NONE - INTEGER, PARAMETER :: LMA = 24 - INTEGER m, iu, j, l, ll, ldn(lm), lup(lm) - REAL*8 :: plb(lm+1) - REAL*4 pb(0 : LMA+1), h2o(jma,0 : LMA), z(LMA), dz(0 : LMA) - CHARACTER*100 title - REAL*4 pdn, pup, dh, fracl - CHARACTER(LEN=300) :: out_line - - !**** read headers/latitudes - READ (iu,'(a)') title - WRITE (out_line,'(''0'',a100)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - READ (iu,'(a)') title - WRITE (out_line,'(1x,a100)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - READ (iu,'(a)') title - ! write(6,'(1x,a100)') title - READ (title(10 : 100),*) (lat_dh2o(j),j=1,jma) - lat_dh2o( : ) = lat_dh2o( : )*radian - - !**** read heights z(km) and data (kg/km^3/year) - DO m = 1, 12 - READ (iu,'(a)') title - WRITE (out_line,'(1x,a100)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - DO l = LMA, 1, -1 - READ (iu,'(a)') title - ! write(6,'(1x,a100)') title - READ (title,*) z(l), (H2O(j,l),j=1,jma) - ENDDO - DO j = 1, jma - h2o(j,0) = 0. - ENDDO - - !**** Find edge heights and pressures - dz(0) = 0. - dz(1) = z(2) - z(1) - DO l = 2, LMA - 1 - dz(l) = .5*(z(l+1)-z(l-1)) - ENDDO - dz(LMA) = z(LMA) - z(LMA-1) - - pb(0) = plb(1) - DO l = 1, LMA - Pb(l) = 1000.*10.**(-(z(l)-.5*dz(l))/16.) - ENDDO - !**** extend both systems vertically to p=0 - pb(LMA+1) = 0. - plb(lm+1) = 0. - - !**** Interpolate vertical resolution to model layers - ldn( : ) = 0 - DO l = 1, lm - DO WHILE ( pb(ldn(l)+1)>=plb(l) .AND. ldn(l)plb(l+1) .AND. lup(l)0 ) THEN - DO ll = ldn(l), lup(l) - pup = MAX(REAL(pb(ll+1),KIND=8),plb(l+1)) - fracl = (pdn-pup)/(pb(ll)-pb(ll+1)) - dh = dh + h2o(j,ll)*fracl*dz(ll) - pdn = pup - ENDDO - ENDIF - DH2O(j,l,m) = 1.D-6*dh/1.74D0/DAYS_PER_YEAR - !->(kg/m^2/ppm_CH4/day) - ENDDO - ENDDO - ENDDO -END SUBROUTINE READ_QMA - -SUBROUTINE LAT_INTERP_QMA(rlat,lev,mon,dh2o_interp) - !@sum interpolate CH4->H2O production rates in latitude - !@auth R. Ruedy - USE RAD_COM, ONLY : jma => JM_DH2O, XLAT => LAT_DH2O, DH2O - IMPLICIT NONE - REAL*8 :: rlat - ! input latitude (radians) - INTEGER :: lev, mon - ! input level, month - REAL*8 :: dh2o_interp - ! output - REAL*8 w1, w2 - INTEGER :: j1, j2 - - !**** Interpolate (extrapolate) horizontally - j2 = 2 + (jma-1)*(rlat-XLAT(1))/(XLAT(jma)-XLAT(1)) - ! first guess - j2 = MIN(MAX(2,j2),jma) - j1 = j2 - 1 - IF ( rlat>XLAT(j2) ) THEN ! j guess was too low - DO WHILE ( j2XLAT(j2) ) - j2 = j2 + 1 - ENDDO - j1 = j2 - 1 - ELSEIF ( rlat1 .AND. rlat1. ) w1 = .5 + .5*w1 - IF ( w1<0. ) w1 = .5*w1 - w2 = 1. - w1 - dh2o_interp = w1*DH2O(j1,lev,mon) + w2*DH2O(j2,lev,mon) -END SUBROUTINE LAT_INTERP_QMA - -#endif /* CUBED_SPHERE */ - -SUBROUTINE GETQMA(iu,dglat,plb,dh2o,lm,jm) - !@sum reads H2O production rates induced by CH4 (Tim Hall) - !@auth R. Ruedy - USE DOMAIN_DECOMP_ATM, ONLY : grid, GETDOMAINBOUNDS, WRITE_PARALLEL - USE TIMECONSTANTS_MOD, ONLY : DAYS_PER_YEAR - IMPLICIT NONE - INTEGER, PARAMETER :: JMA = 18, LMA = 24 - INTEGER m, iu, jm, lm, j, j1, j2, l, ll, ldn(lm), lup(lm) - REAL*8 PLB(lm+1), dH2O(grid%J_STRT_HALO:grid%J_STOP_HALO,lm,12), & - dglat(jm) - REAL*4 pb(0 : LMA+1), h2o(JMA,0 : LMA), xlat(JMA), z(LMA), dz(0 : LMA) - CHARACTER*100 title - REAL*4 pdn, pup, w1, w2, dh, fracl - INTEGER :: j_0, j_1 - CHARACTER(LEN=300) :: out_line - CALL GETDOMAINBOUNDS(grid,J_STRT=J_0,J_STOP=J_1) - - !**** read headers/latitudes - READ (iu,'(a)') title - WRITE (out_line,'(''0'',a100)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - READ (iu,'(a)') title - WRITE (out_line,'(1x,a100)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - READ (iu,'(a)') title - ! write(6,'(1x,a100)') title - READ (title(10 : 100),*) (xlat(j),j=1,JMA) - - !**** read heights z(km) and data (kg/km^3/year) - DO m = 1, 12 - READ (iu,'(a)') title - WRITE (out_line,'(1x,a100)') title - CALL WRITE_PARALLEL(TRIM(out_line),UNIT=6) - DO l = LMA, 1, -1 - READ (iu,'(a)') title - ! write(6,'(1x,a100)') title - READ (title,*) z(l), (H2O(j,l),j=1,JMA) - ENDDO - DO j = 1, JMA - h2o(j,0) = 0. - ENDDO - - !**** Find edge heights and pressures - dz(0) = 0. - dz(1) = z(2) - z(1) - DO l = 2, LMA - 1 - dz(l) = .5*(z(l+1)-z(l-1)) - ENDDO - dz(LMA) = z(LMA) - z(LMA-1) - - pb(0) = plb(1) - DO l = 1, LMA - Pb(l) = 1000.*10.**(-(z(l)-.5*dz(l))/16.) - ENDDO - !**** extend both systems vertically to p=0 - pb(LMA+1) = 0. - plb(lm+1) = 0. - - !**** Interpolate vertical resolution to model layers - ldn( : ) = 0 - DO l = 1, lm - DO WHILE ( pb(ldn(l)+1)>=plb(l) .AND. ldn(l)plb(l+1) .AND. lup(l)xlat(j2) ) - j2 = j2 + 1 - ENDDO - j1 = j2 - 1 - w1 = (xlat(j2)-dglat(j))/(xlat(j2)-xlat(j1)) - !**** for extrapolations, only use half the slope - IF ( w1>1. ) w1 = .5 + .5*w1 - IF ( w1<0. ) w1 = .5*w1 - w2 = 1. - w1 - DO l = 1, lm - dh = 0. - pdn = plb(l) - IF ( lup(l)>0 ) THEN - DO ll = ldn(l), lup(l) - pup = MAX(REAL(pb(ll+1),KIND=8),plb(l+1)) - fracl = (pdn-pup)/(pb(ll)-pb(ll+1)) - dh = dh + (w1*h2o(j1,ll)+w2*h2o(j2,ll)) & - *fracl*dz(ll) - pdn = pup - ENDDO - ENDIF - dh2o(j,l,m) = 1.D-6*dh/1.74D0/DAYS_PER_YEAR - !->(kg/m^2/ppm_CH4/day) - ENDDO - ENDDO - ENDDO -END SUBROUTINE GETQMA - -SUBROUTINE ORBIT(DOBLIQ,ECCEN,DOMEGVP,VEDAY,EDPY,DAY,SDIST,SIND, & - COSD,SUNLON,SUNLAT,EQTIME) - !**** - !**** ORBIT receives orbital parameters and time of year, and returns - !**** distance from Sun, declination angle, and Sun's overhead position. - !**** Reference for following caculations is : V.M.Blanco and - !**** S.W.McCuskey, 1961, "Basic Physics of the Solar System", pages - !**** 135 - 151. Existence of Moon and heavenly bodies other than - !**** Earth and Sun are ignored. Earth is assumed to be spherical. - !**** - !**** Program author : Gary L. Russell 2004/11/16 - !**** Angles, longitude and latitude are measured in radians. - !**** - !**** Input : ECCEN = eccentricity of the orbital ellipse - !**** OBLIQ = latitude of Tropic of Cancer - !**** OMEGVP = longitude of perihelion (sometimes Pi is added) = - !**** = spatial angle from vernal equinox to perihelion - !**** with Sun as angle vertex - !**** DAY = days measured since 2000 January 1, hour 0 - !**** - !**** EDPY = Earth days per year - !**** tropical year = 365.2425 (Gregorgian Calendar) - !**** tropical year = 365 (Generic Year) - !**** VEDAY = Vernal equinox - !**** 79.0 (Generic year Mar 21 hour 0) - !**** 79.5 (Generic year Mar 21 hour 12 - PMIP standard) - !**** 79.3125d0 for days from 2000 January 1, hour 0 till vernal - !**** equinox of year 2000 = 31 + 29 + 19 + 7.5/24 - !**** - !**** Intermediate quantities : - !**** BSEMI = semi minor axis in units of semi major axis - !**** PERIHE = perihelion in days since 2000 January 1, hour 0 - !**** in its annual revolution about Sun - !**** TA = true anomaly = spatial angle from perihelion to - !**** current location with Sun as angle vertex - !**** EA = eccentric anomaly = spatial angle measured along - !**** eccentric circle (that circumscribes Earth's orbit) - !**** from perihelion to point above (or below) Earth's - !**** absisca (where absisca is directed from center of - !**** eccentric circle to perihelion) - !**** MA = mean anomaly = temporal angle from perihelion to - !**** current time in units of 2*Pi per tropical year - !**** TAofVE = TA(VE) = true anomaly of vernal equinox = - OMEGVP - !**** EAofVE = EA(VE) = eccentric anomaly of vernal equinox - !**** MAofVE = MA(VE) = mean anomaly of vernal equinox - !**** SLNORO = longitude of Sun in Earth's nonrotating reference frame - !**** VEQLON = longitude of Greenwich Meridion in Earth's nonrotating - !**** reference frame at vernal equinox - !**** ROTATE = change in longitude in Earth's nonrotating reference - !**** frame from point's location on vernal equinox to its - !**** current location where point is fixed on rotating Earth - !**** SLMEAN = longitude of fictitious mean Sun in Earth's rotating - !**** reference frame (normal longitude and latitude) - !**** - !**** Output : SIND = sine of declination angle = sin(SUNLAT) - !**** COSD = cosine of the declination angle = cos(SUNLAT) - !**** SUNDIS = distance to Sun in units of semi major axis - !**** SUNLON = longitude of point on Earth directly beneath Sun - !**** SUNLAT = latitude of point on Earth directly beneath Sun - !**** EQTIME = Equation of Time = - !**** = longitude of fictitious mean Sun minus SUNLON - !**** - !**** From the above reference : - !**** (4-54) : [1 - ECCEN*cos(EA)]*[1 + ECCEN*cos(TA)] = (1 - ECCEN^2) - !**** (4-55) : tan(TA/2) = sqrt[(1+ECCEN)/(1-ECCEN)]*tan(EA/2) - !**** Yield : tan(EA) = sin(TA)*sqrt(1-ECCEN^2) / [cos(TA) + ECCEN] - !**** or : tan(TA) = sin(EA)*sqrt(1-ECCEN^2) / [cos(EA) - ECCEN] - !**** - USE CONSTANT, ONLY : twopi, pi, radian - IMPLICIT NONE - REAL*8, INTENT(IN) :: DOBLIQ, ECCEN, DOMEGVP, DAY, VEDAY, EDPY - REAL*8, INTENT(OUT) :: SIND, COSD, SDIST, SUNLON, SUNLAT, EQTIME - - REAL*8 MA, OMEGVP, OBLIQ, EA, DEA, BSEMI, TAofVE, EAofVE, MAofVE, & - SUNDIS, TA, SUNX, SUNY, SLNORO, VEQLON, ROTATE, SLMEAN - ! REAL*8, PARAMETER :: EDAYzY=365.2425d0, VE2000=79.3125d0 - ! REAL*8, PARAMETER :: EDAYzY=365d0, VE2000=79d0 ! original parameters - REAL*8 EDAYzY, VE2000 - !**** - VE2000 = VEDAY - EDAYzY = EDPY - OMEGVP = DOMEGVP*radian - OBLIQ = DOBLIQ*radian - !**** Determine EAofVE from geometry : tan(EA) = b*sin(TA) / [e+cos(TA)] - !**** Determine MAofVE from Kepler's equation : MA = EA - e*sin(EA) - !**** Determine MA knowing time from vernal equinox to current day - !**** - BSEMI = SQRT(1-ECCEN*ECCEN) - TAofVE = -OMEGVP - EAofVE = ATAN2(BSEMI*SIN(TAofVE),ECCEN+COS(TAofVE)) - MAofVE = EAofVE - ECCEN*SIN(EAofVE) - ! PERIHE = VE2000 - MAofVE*EDAYzY/TWOPI - MA = MODULO(TWOPI*(DAY-VE2000)/EDAYzY+MAofVE,TWOPI) - !**** - !**** Numerically invert Kepler's equation : MA = EA - e*sin(EA) - !**** - EA = MA + ECCEN*(SIN(MA)+ECCEN*SIN(2*MA)/2) - DO - dEA = (MA-EA+ECCEN*SIN(EA))/(1-ECCEN*COS(EA)) - EA = EA + dEA - IF ( ABS(dEA)<=1D-10 ) THEN - !**** - !**** Calculate distance to Sun and true anomaly - !**** - SUNDIS = 1 - ECCEN*COS(EA) - TA = ATAN2(BSEMI*SIN(EA),COS(EA)-ECCEN) - SDIST = SUNDIS*SUNDIS - ! added for compatiblity - !**** - !**** Change reference frame to be nonrotating reference frame, angles - !**** fixed according to stars, with Earth at center and positive x - !**** axis be ray from Earth to Sun were Earth at vernal equinox, and - !**** x-y plane be Earth's equatorial plane. Distance from current Sun - !**** to this x axis is SUNDIS sin(TA-TAofVE). At vernal equinox, Sun - !**** is located at (SUNDIS,0,0). At other times, Sun is located at : - !**** - !**** SUN = (SUNDIS cos(TA-TAofVE), - !**** SUNDIS sin(TA-TAofVE) cos(OBLIQ), - !**** SUNDIS sin(TA-TAofVE) sin(OBLIQ)) - !**** - SIND = SIN(TA-TAofVE)*SIN(OBLIQ) - COSD = SQRT(1-SIND*SIND) - SUNX = COS(TA-TAofVE) - SUNY = SIN(TA-TAofVE)*COS(OBLIQ) - SLNORO = ATAN2(SUNY,SUNX) - !**** - !**** Determine Sun location in Earth's rotating reference frame - !**** (normal longitude and latitude) - !**** - VEQLON = TWOPI*VE2000 - PI + MAofVE - TAofVE - ! modulo 2*Pi - ROTATE = TWOPI*(DAY-VE2000)*(EDAYzY+1)/EDAYzY - SUNLON = MODULO(SLNORO-ROTATE-VEQLON,TWOPI) - IF ( SUNLON>PI ) SUNLON = SUNLON - TWOPI - SUNLAT = ASIN(SIN(TA-TAofVE)*SIN(OBLIQ)) - !**** - !**** Determine longitude of fictitious mean Sun - !**** Calculate Equation of Time - !**** - SLMEAN = PI - TWOPI*(DAY-FLOOR(DAY)) - EQTIME = MODULO(SLMEAN-SUNLON,TWOPI) - IF ( EQTIME>PI ) EQTIME = EQTIME - TWOPI - EXIT - ENDIF - ENDDO - !**** -END SUBROUTINE ORBIT - -#ifdef HEALY_LM_DIAGS -REAL*8 FUNCTION FE(M,N) - REAL*8 M, N - - FE = 0.47D0*LOG(1.+2.01D-5*(M*N)**(0.75)+5.31D-15*M*(M*N)**(1.52)) -END FUNCTION FE -#endif - -#ifdef CACHED_SUBDD -SUBROUTINE RIJH_DEFS(arr,nmax,decl_count) - ! - ! 2D outputs - ! - USE SUBDD_MOD, ONLY : INFO_TYPE, sched_rad - ! info_type_ is a homemade structure constructor for older compilers - USE SUBDD_MOD, ONLY : INFO_TYPE_ - IMPLICIT NONE - INTEGER :: nmax, decl_count - TYPE (INFO_TYPE) :: arr(nmax) - ! - ! note : next() is a locally declared function to increment decl_count - ! - - decl_count = 0 - - ! - arr(NEXT()) = INFO_TYPE_(SNAME='olrrad',LNAME= & - &'OUTGOING LW RADIATION at TOA (in RADIA)', & - &UNITS='W/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='olrcs',LNAME= & - &'OUTGOING LW RADIATION at TOA, CLEAR-SKY', & - &UNITS='W/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='lwds',LNAME= & - &'LONGWAVE DOWNWARD FLUX at SURFACE',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='lwdscs',LNAME= & - &'LONGWAVE DOWNWARD FLUX at SURFACE, CLEAR-SKY', & - UNITS='W/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='lwus',LNAME= & - &'LONGWAVE UPWARD FLUX at SURFACE',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='totcld',LNAME= & - &'Total Cloud Cover (as seen by rad)',UNITS='%', & - SCALE=1D2,SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='totcld_diag',LNAME= & - &'Total Cloud Cover (continuous, not seen by rad)', & - UNITS='%',SCALE=1D2,SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='cldss_2d',LNAME= & - &'Stratiform Cloud Cover',UNITS='%',SCALE=1D2, & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='cldmc_2d',LNAME= & - &'Convective Cloud Cover',UNITS='%',SCALE=1D2, & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='cod',LNAME= & - &'Cloud optical depth warm clouds',UNITS='-', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='cid',LNAME= & - &'Cloud optical depth ice clouds',UNITS='-', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='wtrcld',LNAME= & - &'Water cloud frequency',UNITS='-',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='icecld',LNAME= & - &'Ice cloud frequency',UNITS='-',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='ctt',LNAME='Cloud top temperature'& - ,UNITS='C',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='ctp',LNAME='Cloud top pressure', & - UNITS='hPa',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swds',LNAME= & - &'SOLAR DOWNWARD FLUX at SURFACE',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swus',LNAME= & - &'SOLAR UPWARD FLUX at SURFACE',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swdf',LNAME= & - &'SOLAR DOWNWARD DIFFUSE FLUX at SURFACE', & - &UNITS='W/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swtoa',LNAME='SOLAR NET FLUX, TOA'& - ,UNITS='W/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swns',LNAME= & - &'Solar net flux at surface',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='lwns',LNAME= & - &'Longwave net flux at surface',UNITS='W/m^2', & - SCHED=sched_rad) - ! -#ifdef CFMIP3_SUBDD /* CFMIP3_SUBDD */ - arr(NEXT()) = INFO_TYPE_(SNAME='rtmt',LNAME= & - &'Net downward radiative flux, TOA',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swut',LNAME='TOA outgoing SW', & - UNITS='W/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swutcs',LNAME= & - &'TOA outgoing SW, CSKY',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='clwvi',LNAME='Total water path', & - UNITS='kg/m^2',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swdcls',LNAME= & - &'SFC downward radiative flux, CSKY',UNITS='kg/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swucls',LNAME= & - &'SFC upward radiative flux, CSKY',UNITS='kg/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swus',LNAME= & - &'SFC upward radiative flux',UNITS='kg/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swdt',LNAME='TOA incoming SW', & - UNITS='W/m^2',SCHED=sched_rad) -#endif /* CFMIP3_SUBDD */ - RETURN -CONTAINS - INTEGER FUNCTION NEXT() - decl_count = decl_count + 1 - NEXT = decl_count - END FUNCTION NEXT -END SUBROUTINE RIJH_DEFS - -SUBROUTINE RIJLH_DEFS(arr,nmax,decl_count) - ! - ! 3D outputs - ! - USE SUBDD_MOD, ONLY : INFO_TYPE, sched_rad - ! info_type_ is a homemade structure constructor for older compilers - USE SUBDD_MOD, ONLY : INFO_TYPE_ - USE CONSTANT, ONLY : kapa - USE TIMECONSTANTS_MOD, ONLY : SECONDS_PER_DAY - IMPLICIT NONE - INTEGER :: nmax, decl_count - TYPE (INFO_TYPE) :: arr(nmax) - ! - ! note : next() is a locally declared function to increment decl_count - ! - decl_count = 0 - ! - arr(NEXT()) = INFO_TYPE_(SNAME='dth_sw',LNAME= & - &'theta tendency from shortwave radiative heating', & - UNITS='K/day',SCALE=1000.**kapa*SECONDS_PER_DAY, & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='dth_lw',LNAME= & - &'theta tendency from longwave radiative heating', & - UNITS='K/day',SCALE=1000.**kapa*SECONDS_PER_DAY, & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='dth_rad',LNAME= & - &'theta tendency from radiative heating', & - &UNITS='K/day',SCALE=1000.**kapa*SECONDS_PER_DAY, & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='lwdp',LNAME= & - &'LONGWAVE DOWNWARD FLUX profile',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='lwup',LNAME= & - &'LONGWAVE UPWARD FLUX profile',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swdp',LNAME= & - &'SHORTWAVE DOWNWARD FLUX profile',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='swup',LNAME= & - &'SHORTWAVE UPWARD FLUX profile',UNITS='W/m^2', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='MRCO2rad',LNAME= & - &'radiation code CO2 volume mixing ratio', & - &UNITS='mole species / mole air',SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='wtrtau',LNAME= & - &'Cloud Water Opacity Seen by Radiation',UNITS='-', & - SCHED=sched_rad) - ! - arr(NEXT()) = INFO_TYPE_(SNAME='icetau',LNAME= & - &'Cloud Ice Opacity Seen by Radiation',UNITS='-', & - SCHED=sched_rad) - ! -#ifdef CFMIP3_SUBDD - arr(NEXT()) = INFO_TYPE_(SNAME='cf',LNAME='Cloud Fraction', & - &UNITS='%',SCALE=1D2,SCHED=sched_rad) - arr(NEXT()) = INFO_TYPE_(SNAME='qcirad',LNAME= & - &'Ice Water Mass Mixing Ratio Seen by Radiation', & - UNITS='kg/kg',SCHED=sched_rad) - arr(NEXT()) = INFO_TYPE_(SNAME='qclrad',LNAME= & - &'Liquid Water Mass Mixing Ratio Seen by Radiation', & - UNITS='kg/kg',SCHED=sched_rad) -#endif - ! - RETURN -CONTAINS - INTEGER FUNCTION NEXT() - decl_count = decl_count + 1 - NEXT = decl_count - END FUNCTION NEXT -END SUBROUTINE RIJLH_DEFS - -#endif - -SUBROUTINE READIFILE(IFile) - ! Consolidated duplicate of MODELE.f code snippets that read the - ! I-file containing the parameter database and INPUTZ namelist. - ! Currently used by radiation-only configuration; to be moved - ! to MODELE.f and used by all configurations once full testing - ! is completed. - ! Note that INPUTZ contains fewer variables in this version. - USE FILEMANAGER, ONLY : OPENUNIT, CLOSEUNIT - USE PARSER_MOD - USE MODEL_COM, ONLY : xlabel, lrunid - USE MODEL_COM, ONLY : HOURI, DATEI, MONTHI, YEARI, IYEAR1 - USE DIAG_COM, ONLY : itwrite - IMPLICIT NONE - !**** Command line options - CHARACTER(LEN=*), INTENT(IN) :: IFile - - INTEGER :: iu_IFILE - !@nlparam IHRI,TIMEE,IHOURE end of model run - !@var IHRI,IHOURE start and end of run in hours (from 1/1/IYEAR1 hr 0) - CHARACTER NLREC*80, RLABEL*132 - !**** List of parameters that are disregarded at restarts - NAMELIST /INPUTZ/ ITWRITE, HOURI, DATEI, MONTHI, YEARI - !**** List of parameters that are disregarded at restarts - NAMELIST /INPUTZ_COLD/ ITWRITE, HOURI, DATEI, MONTHI, YEARI - CHARACTER*132 :: bufs - INTEGER, PARAMETER :: MAXLEN_RUNID = 32 - INTEGER :: lid1, lid2, fid, noff - - - !**** - !**** Reading rundeck (I-file) options - !**** - CALL OPENUNIT(TRIM(ifile),iu_IFILE,.FALSE.,.TRUE.) - CALL PARSE_PARAMS(iu_IFILE) - CALL CLOSEUNIT(iu_IFILE) - - !**** - !**** Print Header and Label (2 lines) from rundeck - !**** - CALL OPENUNIT(TRIM(ifile),iu_IFILE,.FALSE.,.TRUE.) - !if (AM_I_ROOT()) - WRITE (6,'(A,40X,A/)') '0', 'GISS CLIMATE MODEL' - READ (iu_IFILE,'(A80)') XLABEL(1 : 80), NLREC - NOFF = 0 - IF ( XLABEL(73 : 80)==' ' ) NOFF = 8 ! for 72-column rundecks - XLABEL(81-NOFF : 132) = NLREC(1 : 52+NOFF) - !if (AM_I_ROOT()) - WRITE (6,'(A,A/)') '0', XLABEL - RLABEL = XLABEL !@var RLABEL rundeck-label - - lid1 = INDEX(XLABEL,'(') - 1 - IF ( lid1<1 ) lid1 = MAXLEN_RUNID + 1 - lid2 = INDEX(XLABEL,' ') - 1 - IF ( lid2<1 ) lid2 = MAXLEN_RUNID + 1 - LRUNID = MIN(lid1,lid2) - IF ( LRUNID>MAXLEN_RUNID ) CALL STOP_MODEL( & - &'INPUT : Rundeck name too long. Shorten to 32 char or less', & - 255) - - !**** - !**** Read parameters from the rundeck to database and namelist - !**** - DO - READ (iu_IFILE,*,ERR=910,END=910) bufs - ! achar(38) is an ampersand - IF ( bufs == achar(38)//achar(38)//'END_PARAMETERS' ) EXIT - ENDDO - - READ (iu_IFILE,NML=INPUTZ,ERR=900) - - CALL CLOSEUNIT(iu_IFILE) - - IF ( YearI<0 ) THEN - WRITE (6,*) 'Please choose a proper start year yearI, not', & - yearI - CALL STOP_MODEL('INPUT : yearI not provided',255) - ENDIF - - RETURN - !**** - !**** TERMINATE BECAUSE OF IMPROPER PICK-UP - !**** -900 WRITE (6,*) 'Error in NAMELIST parameters' - CALL STOP_MODEL('Error in NAMELIST parameters',255) -910 WRITE (6,*) 'Error readin I-file' - CALL STOP_MODEL('Error reading I-file',255) - -END SUBROUTINE READIFILE - -SUBROUTINE RUN_RADONLY(IFile) - !@sum Call single-column radiation-only model once - USE DICTIONARY_MOD - USE DOMAIN_DECOMP_1D, ONLY : INIT_APP - USE MODEL_COM, ONLY : itime, itimeE, master_yr, xlabel, lrunid - USE MODEL_COM, ONLY : YEARI, IYEAR1 - USE DOMAIN_DECOMP_ATM, ONLY : grid, INIT_GRID -#ifdef CACHED_SUBDD - USE DIAG_COM - USE GEOM, ONLY : lon_dg, lat_dg - USE CDL_MOD -#endif - USE TIMERPACKAGE_MOD, & - ONLY : INITIALIZETIMERPACKAGE_MOD => INITIALIZE - IMPLICIT NONE - !**** Command line options - CHARACTER(LEN=*), INTENT(IN) :: IFile - ! - INTEGER :: i, j, l, n - CHARACTER(LEN=80) :: filenm - - CALL INIT_APP() - - CALL INITIALIZETIMERPACKAGE_MOD() ! avoid probs when RADIA calls timers - - CALL READIFILE(IFile) - - IF ( IS_SET_PARAM("master_yr") ) THEN - CALL GET_PARAM("master_yr",master_yr) - ELSE - CALL STOP_MODEL('Please define master_yr in the rundeck.',255) - ENDIF - - Iyear1 = yearI - - CALL SUNDIAL - - itimeE = itime + 1 - ! for length-1 nominal time axis in diags - - CALL INIT_GRID(grid,1,1,1,WIDTH=0) - - !call alloc_clouds_com(grid) - CALL ALLOC_RAD_COM(grid) - !call alloc_veg_com(grid) - - CALL GEOM_1PT - - CALL INIT_RAD(2) ! istart=2 - CALL DAILY_ORBIT(.FALSE.) ! not end_of_day - CALL DAILY_RAD(.FALSE.) - - CALL PRINT_PARAM(6) - -#ifdef CACHED_SUBDD - ! Initialize diagnostics framework - CALL INIT_CDL_TYPE('cdl_aij',cdl_ij_template) - CALL ADD_COORD(cdl_ij_template,'lon',1,UNITS='degrees_east', & - COORDVALUES=lon_dg( : ,1)) - CALL ADD_COORD(cdl_ij_template,'lat',1,UNITS='degrees_north', & - COORDVALUES=lat_dg( : ,1)) - CALL PARSE_SUBDD - CALL RESET_CACHED_SUBDD - CALL GET_SUBDD_VINTERP_COEFFS - CALL SET_SUBDD_PERIOD() -#endif - - CALL CALC_ZENITH_ANGLE - CALL RADIA - -#ifdef CACHED_SUBDD - filenm = 'allsteps.subdd'//XLABEL(1 : LRUNID) - CALL WRITE_SUBDD_ACCFILE(filenm) -#endif - - CALL STOP_MODEL('Radiation calculations completed.',13) - -CONTAINS - - SUBROUTINE GEOM_1PT - USE GEOM - USE CONSTANT, ONLY : pi, twopi, radian - USE DICTIONARY_MOD, ONLY : GET_PARAM, SYNC_PARAM - IMPLICIT NONE - REAL*8 :: lon_targ, lat_targ - - ! mandatory rundeck parameters : lon and lat of target point - CALL GET_PARAM('lon_targ',lon_targ) - CALL GET_PARAM('lat_targ',lat_targ) - - IF ( ABS(lon_targ)>180D0 .OR. ABS(lat_targ)>90D0 ) & - CALL STOP_MODEL( & - &'geom_atm : invalid lon_targ,lat_targ in rundeck',255) - - LON2D_DG(1,1) = lon_targ - LAT2D_DG(1,1) = lat_targ - - AXYP(1,1) = 1. - - BYAXYP(1,1) = 1D0/AXYP(1,1) - - LON2D(1,1) = LON2D_DG(1,1)*radian - LAT2D(1,1) = LAT2D_DG(1,1)*radian - - SINLAT2D(1,1) = SIN(LAT2D(1,1)) - COSLAT2D(1,1) = COS(LAT2D(1,1)) - LON2D(1,1) = LON2D(1,1) + pi ! IDL has a value of zero - IF ( LON2D(1,1)<0. ) LON2D(1,1) = LON2D(1,1) + twopi - - imaxj = 1 - - lon_dg = LON2D_DG - lat_dg = LAT2D_DG - - END SUBROUTINE GEOM_1PT - - SUBROUTINE SUNDIAL - ! Duplicate of relevant snippets of clock initialization in MODELE.f. - ! Currently used by radiation-only configuration; will disappear - ! once the clock initialization in MODELE.f has been cleanly isolated - ! from other intialization activities. - USE DICTIONARY_MOD - USE MODEL_COM, ONLY : nday, dtsrc, itime, itimei, HOURI, DATEI, & - MONTHI, YEARI - USE MODEL_COM, ONLY : modelEclock, calendar - USE MODELCLOCK_MOD, ONLY : MODELCLOCK -#ifdef TRACERS_GC - USE TEMPUS_MOD -#else - USE TIME_MOD -#endif - USE BASETIME_MOD - USE RATIONAL_MOD - USE TIMEINTERVAL_MOD - IMPLICIT NONE - - TYPE (TIME) :: MODELETIME0 - TYPE (TIME) :: MODELETIME - TYPE (TIMEINTERVAL) :: dtSrcUsed - TYPE (TIMEINTERVAL) :: secsPerDay - - !**** Get those parameters which are needed in this subroutine - CALL GET_PARAM("DTsrc",DTsrc) - - !@var NDAY=(1 day)/DTsrc : even integer; adjust DTsrc to be commensurate - secsPerDay = calendar%GETSECONDSPERDAY() - NDAY = 2*NINT((secsPerDay/(DTsrc*2))) - dtSrcUsed = TIMEINTERVAL(secsPerDay/NDAY) - DTsrc = REAL(dtSrcUsed) - - MODELETIME0 = NEWTIME(calendar) - MODELETIME = NEWTIME(calendar) - - CALL MODELETIME%SETBYDATE(yearI,monthI,dateI,hourI) - CALL MODELETIME0%SETBYDATE(yearI,MONTH=1,DATE=1,HOUR=0) - - ITimeI = NINT((MODELETIME-MODELETIME0)/dtSrcUsed) - Itime = ItimeI - - modelEclock = MODELCLOCK(MODELETIME,dtSrcUsed,itime) - - CALL DAILY_CAL(.FALSE.) ! not end_of_day - - END SUBROUTINE SUNDIAL - -END SUBROUTINE RUN_RADONLY diff --git a/model/RAD2_UTILS.F90 b/model/RAD2_UTILS.F90 deleted file mode 100644 index 298afa5..0000000 --- a/model/RAD2_UTILS.F90 +++ /dev/null @@ -1,4035 +0,0 @@ -!@sum This file contains the radiation subroutines which don''t use -!@+ the module RADPAR. They are used by RADIATION and/or ALBEDO. -#include "rundeck_opts.h" - - MODULE GTAU_STATE_MOD - SAVE - REAL*8 :: GTAU(51,11,143) - REAL*8 :: TAUGSA(1001,14), SALBTG(768,14), TAUTGS(768), & - TAUTGD(122) - END MODULE GTAU_STATE_MOD - - SUBROUTINE RXSNOW(RBSNO,XCOSZ,GGSNO,RXSNO) -!@sum RXSNOW calculate zenith angle dependence for snow/ice albedo -!@auth A. Lacis (modified by G. Schmidt) - ! USE RADPAR, only : gtsalb,sgpgxg - IMPLICIT NONE -!@var RBSNO diffuse albedo - REAL*8, INTENT(IN) :: RBSNO -!@var XCOSZ zenith angle - REAL*8, INTENT(IN) :: XCOSZ -!@var GGSNO Asymmetry parameter for snow - REAL*8, INTENT(IN) :: GGSNO -!@var RXSNO direct albedo - REAL*8, INTENT(OUT) :: RXSNO - INTEGER NDBLS, NN - REAL*8 XXG, XXT, GGSN, RBSN, FRTOP, TAU, TAUSN, GPFF, PR, PT, & - DBLS, SECZ, XANB, XANX, TANB, TANX, RASB, RASX, BNORM, & - XNORM, RARB, RARX, XATB, DENOM, DB, DX, UB, UX, DRBRAT, & - RBBOUT - - IF ( RBSNO<0.05D0 ) THEN - RXSNO = RBSNO - RETURN - ENDIF - XXG = 0.D0 - XXT = 0.D0 - GGSN = GGSNO - IF ( GGSNO>0.9D0 ) GGSN = 0.9D0 - RBSN = RBSNO - FRTOP = 1.D0 - IF ( RBSNO>0.5D0 ) THEN - RBSN = 0.5D0 - FRTOP = ((1.D0-RBSNO)/0.5D0)**2 - ENDIF - - CALL GTSALB(XXG,XXT,RBBOUT,RBSN,GGSN,TAUSN,2) - CALL SGPGXG(XCOSZ,TAUSN,GGSN,GPFF) - PR = 1.D0 - GPFF - PT = 1.D0 + GPFF - DBLS = 10.D0 + 1.44269D0*LOG(TAUSN) - NDBLS = DBLS - TAU = TAUSN/2**NDBLS -! Set optically thin limit values of R,T,X using PI0 renormalization -! ------------------------------------------------------------------ -! - SECZ = 1.D0/XCOSZ - XANB = EXP(-TAU-TAU) - XANX = EXP(-TAU*SECZ) - TANB = PT*XANB - XXT = (SECZ-2.D0)*TAU - TANX = PT*SECZ* & - (.5D0+XXT*(.25D0+XXT*(.0833333D0+XXT*(.0208333D0+XXT)))) & - *XANX - RASB = PR*(1.D0-TAU*(2.D0-2.66667D0*TAU*(1.D0-TAU))) - XXT = (SECZ+2.D0)*TAU - RASX = PR*SECZ* & - (.5D0-XXT*(.25D0-XXT*(.0833333D0-XXT*(.0208333D0-XXT)))) - BNORM = (1.D0-XANB)/(RASB+TANB) - XNORM = (1.D0-XANX)/(RASX+TANX) - RASB = RASB*BNORM - RASX = RASX*XNORM - TANB = TANB*BNORM - TANX = TANX*XNORM - DO NN = 1, NDBLS - RARB = RASB*RASB - RARX = XANX*RASX - XATB = XANB + TANB - DENOM = 1.D0 - RARB - DB = (TANB+XANB*RARB)/DENOM - DX = (TANX+RARX*RASB)/DENOM - UB = RASB*(XANB+DB) - UX = RARX + RASB*DX - RASB = RASB + XATB*UB - RASX = RASX + XATB*UX - TANB = XANB*TANB + XATB*DB - TANX = XANX*TANX + XATB*DX - XANB = XANB*XANB - XANX = XANX*XANX - ENDDO - DRBRAT = RASX/RBSN - 1.D0 - RXSNO = RBSNO*(1.D0+DRBRAT*FRTOP) - END SUBROUTINE RXSNOW - - SUBROUTINE SETGTS(tgdata_in) - USE GTAU_STATE_MOD - IMPLICIT NONE - REAL*8, INTENT(IN) :: tgdata_in(122,13) - REAL*8 CWM, CWE, TIJ, RBB, RBBI, BTAU - INTEGER I, J - - REAL*8 :: tgdata(122,13) - ! why cant we just - TGDATA = tgdata_in ! pass tgdata_in to spline - - DO I = 1, 122 - TAUTGD(I) = (I-1)*0.1D0 - IF ( I>24 ) TAUTGD(I) = (I-24)*0.2D0 + 2.2D0 - IF ( I>48 ) TAUTGD(I) = (I-48)*0.5D0 + 7.0D0 - IF ( I>72 ) TAUTGD(I) = (I-72) + 19.0D0 - IF ( I>96 ) TAUTGD(I) = (I-96)*5.0D0 + 40.0D0 - IF ( I>112 ) TAUTGD(I) = (I-112)*100.0D0 + 100.0D0 - IF ( I==121 ) TAUTGD(I) = 9999.99D0 - IF ( I==122 ) TAUTGD(I) = 12000.0D0 - ENDDO - - DO I = 1, 768 - IF ( I<602 ) TAUTGS(I) = (I-1)*0.05D0 - IF ( I>601 ) TAUTGS(I) = (I-601)*0.50D0 + 30.0D0 - IF ( I>741 ) TAUTGS(I) = (I-741)*50.0D0 + 100.D0 - IF ( I>758 ) TAUTGS(I) = (I-758)*1000.D0 - ENDDO - - DO J = 1, 13 - DO I = 1, 768 - CWM = 0.5 - CWE = 0.5 - IF ( I>759 ) CWM = 0.0 - IF ( I>759 ) CWE = 0.0 - TIJ = TAUTGS(I) - CALL SPLINE(TAUTGD,TGDATA(1,J),122,TIJ,RBBI,CWM,CWE,0) - SALBTG(I,J) = RBBI - ENDDO - ENDDO - DO J = 1, 13 - DO I = 2, 1000 - RBB = (I-1)*0.001D0 - CWM = 0.5 - CWE = 0.5 - CALL SPLINE(SALBTG(1,J),TAUTGS,768,RBB,BTAU,CWM,CWE,0) - TAUGSA(I,J) = BTAU - ENDDO - ENDDO - SALBTG(1,:) = 0 ! 1:14 - TAUGSA(1,:) = 0 - TAUGSA(1001,:) = 10000 - - SALBTG(:,14) = SALBTG(:,13)*2 - SALBTG(:,12) ! 1:768 - TAUGSA(:,14) = TAUGSA(:,13)*2 - TAUGSA(:,12) ! 1:1001 - - END SUBROUTINE SETGTS - - SUBROUTINE GTSALB(GIN,TAUIN,RBBOUT,RBBIN,EGIN,TAUOUT,KGTAUR) - USE GTAU_STATE_MOD - IMPLICIT NONE - REAL*8, INTENT(IN) :: GIN, TAUIN, RBBIN, EGIN - INTEGER, INTENT(IN) :: KGTAUR - REAL*8, INTENT(OUT) :: RBBOUT, TAUOUT - - REAL*8 FFKG(4,3), RBBK(3) - REAL*8, PARAMETER, DIMENSION(14) & - :: GVALUE = (/.0,.25,.45,.50,.55, & - .60,.65,.70,.75,.80,.85,.90,.95,1./) - REAL*8 RBB, G, TAU, EG, DELTAU, TI, WTJ, WTI, GI, WGI, WGJ, F1, & - F2, F3, F4, A, B, C, RB2, RB3, TBB, TB2, TB3, XG, XM, XP, & - RBBB, RI, WRJ, WRI, EI, WEI, WEJ, DELALB, X1, X2, X3, X4, & - XX, BB, DTAU - INTEGER K, KTERPL, IT, JT, IG, JG, ITERPL, IGM, JGP, KG, IR, JR, & - IE, JE, IEM, JEP - REAL*8, EXTERNAL :: COMPUTE - KTERPL = 0 - - G = GIN - TAU = TAUIN - RBB = RBBIN - EG = EGIN - - RBBOUT = 0.0 - TAUOUT = 0.0 -! --------------------------- -! OPTICAL DEPTH INTERPOLATION -! 0.05 ON (0.00 < TAU < 30.0) -! 0.50 ON (30.0 < TAU < 100.) -! 50.0 ON (100. < TAU < 1000) -! --------------------------- - - IF ( KGTAUR==2 ) GOTO 300 - - - 200 DELTAU = 0.05D0 - TI = TAU/DELTAU - IT = TI - IF ( IT>599 ) THEN - DELTAU = 0.50D0 - TI = TAU/DELTAU - IT = TI - IF ( IT>199 ) THEN - DELTAU = 50.0D0 - TI = TAU/DELTAU - IT = TI - IF ( IT>19 ) THEN - DELTAU = 1000.0D0 - TI = TAU/DELTAU - IT = TI - WTJ = TI - IT - WTI = 1.0 - WTJ - IT = IT + 758 - ELSE - WTJ = TI - IT - WTI = 1.0 - WTJ - IT = IT + 649 - ENDIF - ELSE - WTJ = TI - IT - WTI = 1.0 - WTJ - IT = IT + 541 - ENDIF - ELSE - WTJ = TI - IT - WTI = 1.D0 - WTJ - IT = IT + 1 - ENDIF - JT = IT + 1 - -! --------------------------------- -! ASYMMETRY PARAMETER INTERPOLATION -! 0.05 CUBIC SPLINE (0.5 < G < 0.9) -! 0.25 QUADRATIC ON (0.0 < G < 0.5) -! LINEAR EXTRAP FOR (.95 < G < 1.0) -! --------------------------------- - - GI = G*20.D0 - IF ( GI>10.0 ) THEN - - ITERPL = 4 - IG = GI - WGJ = GI - IG - WGI = 1.D0 - WGJ - IG = IG - 6 - IF ( IG>12 ) THEN - ITERPL = 2 - IG = 12 - ENDIF - JG = IG + 1 - ELSE - IG = 2 - JG = 3 - ITERPL = 1 - ENDIF - - - IGM = IG - 1 - JGP = JG + 1 - - K = 0 - DO KG = IGM, JGP - K = K + 1 - F1 = SALBTG(IT-1,KG) - F2 = SALBTG(IT,KG) - F3 = SALBTG(JT,KG) - F4 = SALBTG(JT+1,KG) - IF ( IT==1 ) F1 = -F3 - FFKG(K,1) = COMPUTE(F1,F2,F3,F4,WTJ) - FFKG(K,2) = F2 - FFKG(K,3) = F3 - ENDDO - - IF ( ITERPL<4 ) THEN - - XG = G*2.D0 - 0.5D0 - IF ( ITERPL==2 ) XG = G*10.D0 - 9.D0 - XM = 1.D0 - XG - XG - XP = 1.D0 + XG + XG - RBB = XM*XP*FFKG(ITERPL+1,1) - XG*XM*FFKG(ITERPL,1) & - + XG*XP*FFKG(4,1) - RB2 = XM*XP*FFKG(ITERPL+1,2) - XG*XM*FFKG(ITERPL,2) & - + XG*XP*FFKG(4,2) - RB3 = XM*XP*FFKG(ITERPL+1,3) - XG*XM*FFKG(ITERPL,3) & - + XG*XP*FFKG(4,3) - - IF ( KGTAUR==1 ) RETURN - IF ( KTERPL==1 ) GOTO 400 - ELSE - - DO K = 1, 3 - F1 = FFKG(1,K) - F2 = FFKG(2,K) - F3 = FFKG(3,K) - F4 = FFKG(4,K) - RBBK(K) = COMPUTE(F1,F2,F3,F4,WGJ) - ENDDO - RBB = RBBK(1) - RB2 = RBBK(2) - RB3 = RBBK(3) - TBB = TAU - TB2 = TAUTGS(IT) - TB3 = TAUTGS(JT) - IF ( KGTAUR==1 ) RETURN - IF ( KTERPL==1 ) GOTO 400 - ENDIF - - 300 RBBB = RBB - - RI = RBB*1000.D0 - IR = RI - WRJ = RI - IR - WRI = 1.D0 - WRJ - IR = IR + 1 - JR = IR + 1 - - EI = EG*20.D0 - IF ( EI>10.0 ) THEN - - ITERPL = 4 - IE = EI - WEJ = EI - IE - WEI = 1.D0 - WEJ - IE = IE - 6 - IF ( IE>12 ) THEN - ITERPL = 2 - IE = 12 - ENDIF - JE = IE + 1 - ELSE - IE = 2 - JE = 3 - ITERPL = 1 - ENDIF - - DELALB = 0.001D0 - IEM = IE - 1 - JEP = JE + 1 - K = 0 - DO KG = IEM, JEP - K = K + 1 - F1 = TAUGSA(IR-1,KG) - F2 = TAUGSA(IR,KG) - F3 = TAUGSA(JR,KG) - F4 = TAUGSA(JR+1,KG) - IF ( IR==1 ) F1 = -F3 - FFKG(K,1) = COMPUTE(F1,F2,F3,F4,WRJ) - FFKG(K,2) = F2 - FFKG(K,3) = F3 - ENDDO - X1 = GVALUE(IE-1) - X2 = GVALUE(IE) - X3 = GVALUE(JE) - X4 = GVALUE(JE+1) - XX = WEJ - IF ( ITERPL<4 ) THEN - - XG = EG*2.D0 - 0.5D0 - IF ( ITERPL==2 ) XG = G*10.D0 - 9.D0 - XM = 1.D0 - XG - XG - XP = 1.D0 + XG + XG - TBB = XM*XP*FFKG(ITERPL+1,1) - XG*XM*FFKG(ITERPL,1) & - + XG*XP*FFKG(4,1) - TB2 = XM*XP*FFKG(ITERPL+1,2) - XG*XM*FFKG(ITERPL,2) & - + XG*XP*FFKG(4,2) - TB3 = XM*XP*FFKG(ITERPL+1,3) - XG*XM*FFKG(ITERPL,3) & - + XG*XP*FFKG(4,3) - IF ( KTERPL==1 ) GOTO 400 - ELSE - - DO K = 1, 3 - F1 = FFKG(1,K) - F2 = FFKG(2,K) - F3 = FFKG(3,K) - F4 = FFKG(4,K) - RBBK(K) = COMPUTE(F1,F2,F3,F4,WEJ) - ENDDO - TBB = RBBK(1) - TB2 = RBBK(2) - TB3 = RBBK(3) - - IF ( KTERPL==1 ) GOTO 400 - ENDIF - KTERPL = 1 - TAU = TBB - G = EGIN - GOTO 200 - 400 IF ( ABS(WTI*WTJ)<0.1D0 ) DTAU = (RBBB-RB2)/(RB3-RB2) - IF ( ABS(WTI*WTJ)>=0.1D0 ) THEN - C = (RB3-RBB)/WTI - (RBB-RB2)/WTJ - B = (RBB-RB2)/WTJ - WTJ*C - A = RB2 - BB = B*B + 4.D0*C*(RBBB-A) - IF ( BB>0.D0 ) DTAU = (SQRT(BB)-B)/(C+C) - ENDIF - TAUOUT = (IT-1+DTAU)*DELTAU - RBBOUT = RBBB - - - END SUBROUTINE GTSALB - - SUBROUTINE SGPGXG(XMU,TAU,G,GG) - USE GTAU_STATE_MOD - IMPLICIT NONE -! ---------------------------------------------------------------- -! COSBAR ADJUSTMENT TO REPRODUCE THE SOLAR ZENITH ANGLE DEPENDENCE -! FOR AEROSOL ALBEDO FOR OPTICAL THICKNESSES [0.0 < TAU < 10000.0] -! ---------------------------------------------------------------- - REAL*8, INTENT(IN) :: XMU, TAU, G - REAL*8, INTENT(OUT) :: GG - REAL*8 XI, WXI, WXJ, GI, WGI, WGJ, TI, WTJ, WTI - INTEGER IX, JX, IG, JG, IT, IT0, JT -! ------------------------------------------- -! XMU (COSZ) SOLAR ZENITH ANGLE INTERPOLATION -! DATA INTERVAL: 0.02 ON [0.0 < XMU < 1.0] -! ------------------------------------------- - - XI = XMU*50.D0 + 0.999999D0 - ! >1 since XMU=COSZ>.001 - IX = XI - JX = IX + 1 - WXJ = XI - IX - WXI = 1.D0 - WXJ - -! ------------------------------- -! COSBAR DEPENDENCE INTERPOLATION -! 0.10 ON [0.0 < COSBAR < 1.0] -! ------------------------------- - - GI = G*10.D0 - IG = GI - WGJ = GI - IG - WGI = 1.D0 - WGJ - IG = IG + 1 - JG = IG + 1 - -! ----------------------------------------- -! AEROSOL TAU INTERPOLATION INTERVALS -! ----------------------------------------- -! dTau 1 1 (Lin Int) 61 62 -! 0.10 ON [0.00 , 0.00 < TAU < 6.00 , 6.10] -! 63 64 92 93 -! 0.50 ON [5.50 , 6.00 < TAU < 20.0 , 20.5] -! 94 95 111 112 -! 5.00 ON [15.0 , 20.0 < TAU < 100. , 105.] -! 113 114 132 133 -! 50.0 ON [50.0 , 100. < TAU < 1000 , 1050] -! 134 143 -! 1000 ON [ , 1000 < TAU < 10000, ] -! ----------------------------------------- - - IF ( TAU<6.D0 ) THEN - TI = TAU*10.D0 + 1. - IT = TI - WTJ = TI - IT - IT0 = 0 - - ELSEIF ( TAU<20.D0 ) THEN - TI = (TAU-6.D0)*2.00D0 + 2.D0 - IT = TI - WTJ = TI - IT - IT0 = 62 - - ELSEIF ( TAU<100.D0 ) THEN - TI = (TAU-20.D0)*0.20D0 + 2.D0 - IT = TI - WTJ = TI - IT - IT0 = 93 - - ELSEIF ( TAU<1000.D0 ) THEN - TI = (TAU-100.D0)*0.02D0 + 2.D0 - IT = TI - WTJ = TI - IT - IT0 = 112 - - ELSE - TI = TAU*0.001D0 + 1.D-6 - IT = TI - WTJ = TI - IT - IF ( IT>9 ) IT = 9 - IT0 = 133 - ENDIF - - WTI = 1.D0 - WTJ - IT = IT + IT0 - JT = IT + 1 - GG = WGI*(WTI*(WXI*GTAU(IX,IG,IT)+WXJ*GTAU(JX,IG,IT)) & - +WTJ*(WXI*GTAU(IX,IG,JT)+WXJ*GTAU(JX,IG,JT))) & - + WGJ*(WTI*(WXI*GTAU(IX,JG,IT)+WXJ*GTAU(JX,JG,IT)) & - +WTJ*(WXI*GTAU(IX,JG,JT)+WXJ*GTAU(JX,JG,JT))) - - RETURN - - END SUBROUTINE SGPGXG - - SUBROUTINE SET_SGPGXG(GTAU_IN) - USE GTAU_STATE_MOD - REAL*8, INTENT(IN) :: GTAU_IN(51,11,143) - GTAU = GTAU_IN - END SUBROUTINE SET_SGPGXG - - SUBROUTINE SPLINE(X,F,NXF,XX,FF,CUSPWM,CUSPWE,KXTRAP) - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NXF, KXTRAP - REAL*8, INTENT(IN) :: X(NXF), F(NXF), XX, CUSPWM, CUSPWE - REAL*8, INTENT(OUT) :: FF - REAL*8 :: FFVEC(1) - -!--------------------------------------------------------------------- -! -! SPLINE locates XX between points (F2,X2)(F3,X3) on 4-point spread -! and returns 4-point Cubic Spline interpolated value FF = F(XX) -! -! Quadratic Derivatives of Spline are continuous at (F2,X2),(F3,X3) -! (X-Coordinate may be specified in increasing or decreasing order) -! -!--------------------------------------------------------------------- -! -! Custom Control Parameters: CUSPWM,CUSPWE,KXTRAP -!------------------------------ -! -! In cases where data points are unevenly spaced and/or data points -! exhibit abrupt changes in value, Spline Interpolation may produce -! undesirable bulging of interpolated values. In more extreme cases -! Linear Interpolation may be less problematic to use. -! -! Interpolation can be weighted between: Cubic Spline and Linear by -! adjusting weights CUSPWM and CUSPWE to values between 1.0 and 0.0 -! -! CUSPWM = Cubic Spline Weight at the (X2-X3) Interval Mid-point -! CUSPWE = Cubic Spline Weight at the (X2-X3) Interval End-points -! -! For example, with: -! -! CUSPWM=1.0,CUSPWE=1.0 FF returns Cubic Spline interpolated value -! CUSPWM=0.0,CUSPWE=0.0 FF returns Linearly interpolated value -! -!--------------------------------------------------------------------- -! -! Extrapolation for XX outside of defined interval: X(1)<->X(NXF) -! -! KXTRAP = 0 No Extrapolation (i.e., sets F(XX)=0.0) -! 1 Fixed Extrapolation (F(XX) = edge value) -! 2 Linear Extrapolation using 2 edge points -! -!--------------------------------------------------------------------- - - FFVEC(1) = FF - CALL SPLINEVECTOR(X,F,1,NXF,XX,FFVEC,CUSPWM,CUSPWE,KXTRAP) - FF = FFVEC(1) - - END SUBROUTINE SPLINE - - SUBROUTINE SPLINEVECTOR(X,F,NVEC,NXF,XX,FF,CUSPWM,CUSPWE,KXTRAP) - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NVEC, NXF, KXTRAP - REAL*8, INTENT(IN) :: X(NXF), F(NVEC,NXF), XX, CUSPWM, CUSPWE - REAL*8, INTENT(OUT) :: FF(NVEC) - -!--------------------------------------------------------------------- -! -! SPLINEVector is identical to SPLINE, except operates on vector functions -! rather than scalar functions. More efficient than calling in a loop. -! -!--------------------------------------------------------------------- - - REAL*8 x1, x2, x3, x4, x21, x32, x43, x31, x42, betw, CUSPWT - REAL*8, DIMENSION(NVEC) :: f1, f2, f3, f4 - REAL*8, DIMENSION(NVEC) :: f21, f32, f43, f3221, f4332 - REAL*8, DIMENSION(NVEC) :: A, B, C, D, FFCUSP, FFLINR - REAL*8 xf, xe, xexm - INTEGER K - - K = 2 - X2 = X(K) - X3 = X(NXF-1) - BETW = (XX-X2)*(X3-XX) - IF ( BETW<=0.D0 ) THEN - -! Edge Point Interval Interpolation and/or Extrapolation -! ------------------------------------------------------ - BETW = (X2-XX)*(X3-X2) - IF ( BETW<0.D0 ) THEN - -! X(NXF-1),X(NXF) Edge Point Interval Interpolation -! -------------------------------------------------- - F3 = F(:,NXF) - X3 = X(NXF) - F2 = F(:,NXF-1) - X2 = X(NXF-1) - X32 = X3 - X2 - F32 = (F3-F2)/X32 - XF = XX - X3 - BETW = (X2-XX)*(XX-X3) - IF ( BETW<0.D0 ) THEN - -! Extrapolation for X Outside of Interval X(NXF-1)-X(NXF) -! -------------------------------------------------------- -! IF(KXTRAP == 0) (No Extrapolation: sets F(XX)=0.0) -! IF(KXTRAP == 1) (Extrapolation at Fixed Edge Value) -! IF(KXTRAP == 2) (2 Edge Point Linear Extrapolation) - - IF ( KXTRAP==0 ) FF = 0.D0 - IF ( KXTRAP==1 ) FF = F3 - IF ( KXTRAP==2 ) FF = F3 + XF*(F3-F2)/(X3-X2) - ELSE - F1 = F(:,NXF-2) - X1 = X(NXF-2) - X21 = X2 - X1 - X31 = X3 - X1 - F21 = (F2-F1)/X21 - XF = XX - X2 - -! 3-Point Quadratic Interpolation for Edge Intervals -! -------------------------------------------------- -! -! (Edge Option) ---------------------------------------------- -! For Linear Interpolation within Edge Intervals -! between X(1),X(2), and between X(NXF-1),X(NXF) -! set the value of coefficient C below, to C=0.0 -! ---------------------------------------------- - - C = (F32-F21)/X31 - B = F21 + X21*C - A = F2 - FFCUSP = A + XF*(B+XF*C) - FFLINR = A + XF*F32 - XE = 1.D0 - 2.D0*XF/X32 - IF ( XE<0.D0 ) XE = -XE - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - FF = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - ENDIF - ELSE - -! X(1),X(2) Edge Point Interval Interpolation -! -------------------------------------------- - X1 = X(1) - F1 = F(:,1) - F2 = F(:,2) - X21 = X2 - X1 - F21 = (F2-F1)/X21 - XF = XX - X1 - BETW = (X2-XX)*XF - IF ( BETW<0.D0 ) THEN - -! Extrapolation for XX Outside of Interval X(1) - X(2) -! ---------------------------------------------------- -! IF(KXTRAP == 0) (No Extrapolation: sets F(XX)=0.0) -! IF(KXTRAP == 1) (Extrapolation at Fixed Edge Value) -! IF(KXTRAP == 2) (2 Edge Point Linear Extrapolation) - - IF ( KXTRAP==0 ) FF = 0.D0 - IF ( KXTRAP==1 ) FF = F1 - IF ( KXTRAP==2 ) FF = F1 + XF*F21 - ELSE - F3 = F(:,3) - X3 = X(3) - X32 = X3 - X2 - X31 = X3 - X1 - C = ((F3-F2)/X32-F21)/X31 - B = F21 - X21*C - A = F1 - FFCUSP = A + XF*(B+XF*C) - FFLINR = A + XF*F21 - XE = 1.D0 - 2.D0*XF/X21 - IF ( XE<0.D0 ) XE = -XE - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - FF = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - ENDIF - ENDIF - ELSE - DO - - K = K + 1 - X3 = X(K) - BETW = (XX-X2)*(X3-XX) - IF ( BETW>=0.D0 ) THEN - - F3(:) = F(:,K) - F4(:) = F(:,K+1) - X4 = X(K+1) - F2(:) = F(:,K-1) - X2 = X(K-1) - F1(:) = F(:,K-2) - X1 = X(K-2) - X21 = X2 - X1 - X31 = X3 - X1 - X32 = X3 - X2 - X43 = X4 - X3 - X42 = X4 - X2 - F21(:) = (F2(:)-F1(:))/(X21*X21) - F32(:) = (F3(:)-F2(:))/(X32*X32) - F43(:) = (F4(:)-F3(:))/(X43*X43) - F3221(:) = (F32(:)+F21(:))/X31*X21 - F4332(:) = (F43(:)+F32(:))/X42*X43 - A = F2 - B = X32*F3221 - C = 3.D0*F32 - F3221 - F3221 - F4332 - D = (F3221+F4332-F32-F32)/X32 - XF = XX - X2 - -! FFCUSP= Cubic Spline Interpolation Result -! ----------------------------------------- - - FFCUSP = A + XF*(B+XF*(C+XF*D)) - XE = (X3+X2-XX-XX)/X32 - IF ( XE<0.D0 ) XE = -XE - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - -! FFLINR= Linear Interpolation Result -! ----------------------------------- - FFLINR = A + XF*F32*X32 - FF = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - EXIT - ELSE - X2 = X3 - ENDIF - ENDDO - ENDIF - - END SUBROUTINE SPLINEVECTOR -!cc the following subroutines were just moved from RADIATION.f to -!cc reduce its size. Only MODULE RADPAR subroutines or those that -!cc USE RADPAR module were left. - - SUBROUTINE BOXAV1(DEGLAT,TAULAT,NLAT,JALIM,JBLIM,TAU) - IMPLICIT NONE -! -!-------------------------------------------------------------------- -! BOXAV1 Performs: -! Latitudinal average (area-weighted) of TAULAT -! -! DEGLAT Center latitude of grid-box variable (TAULAT) -! of the form: DEGLAT = -90+(J-1)*180/(NLAT-1) -! -! TAULAT Zonal average value is constant over grid-bos -! -! JALIM, JBLIM Latitude boxes for which (TAULAT) is averaged -! -! TAU Area-weighted (TAULAT) latitude average value -!-------------------------------------------------------------------- -! - INTEGER, INTENT(IN) :: NLAT, JALIM, JBLIM - REAL*8, DIMENSION(NLAT), INTENT(IN) :: DEGLAT, TAULAT - REAL*8, INTENT(OUT) :: TAU - REAL*8 :: ASUM, TSUM - REAL*8 :: ONES(NLAT) - - ONES = 1.0D0 - CALL BOXAV(DEGLAT,ONES,TAULAT,NLAT,JALIM,JBLIM,TSUM,ASUM) - TAU = TSUM/ASUM - - END SUBROUTINE BOXAV1 - - SUBROUTINE BOXAV2(DEGLAT,TAULAT,SIZLAT,NLAT,JALIM,JBLIM,SIZ) - IMPLICIT NONE -! -!-------------------------------------------------------------------- -! BOXAV2 Performs: -! TAULAT-weighted latitudinal average of SIZLAT -! -! DEGLAT Center latitude of grid-box variable (TAULAT) -! of the form: DEGLAT = -90+(J-1)*180/(NLAT-1) -! -! TAULAT Zonal average value is constant over grid-box -! SIZLAT Zonal average value is constant over grid-box -! -! JALIM, JBLIM Latitude boxes for which variable is averaged -! -! SIZ TAULAT-weighted latitudinal average of SIZLAT -!-------------------------------------------------------------------- -! - INTEGER, INTENT(IN) :: NLAT, JALIM, JBLIM - REAL*8, DIMENSION(NLAT), INTENT(IN) :: DEGLAT, TAULAT, SIZLAT - REAL*8, INTENT(OUT) :: SIZ - REAL*8 ASUM, TSUM - - CALL BOXAV(DEGLAT,TAULAT,SIZLAT,NLAT,JALIM,JBLIM,TSUM,ASUM) - SIZ = (1.D-20+TSUM)/(1.D-10+ASUM) - - END SUBROUTINE BOXAV2 - - SUBROUTINE BOXAV(DEGLAT,W1,ARR,NLAT,JALIM,JBLIM,TSUM,ASUM) - IMPLICIT NONE -! -!-------------------------------------------------------------------- -! BOXAV Performs: -! W1 weighted sums of ARR -! -! DEGLAT Center latitude of grid-box variable (W1) -! of the form: DEGLAT = -90+(J-1)*180/(NLAT-1) -! -! W1 Zonal average value is constant over grid-box -! SIZLAT Zonal average value is constant over grid-box -! -! JALIM, JBLIM Latitude boxes for which variable is averaged -! -!-------------------------------------------------------------------- -! - INTEGER, INTENT(IN) :: NLAT, JALIM, JBLIM - REAL*8, DIMENSION(NLAT), INTENT(IN) :: DEGLAT, W1, ARR - REAL*8, INTENT(OUT) :: TSUM, ASUM - REAL*8 PI, RADIAN, RLAT1, RLAT2, ALAT1, ALAT2, ALATJ - INTEGER J, J1, J2 - - ASUM = 0.D0 - TSUM = 0.D0 - PI = ACOS(-1.D0) - RADIAN = 180.D0/PI - J1 = JALIM - 1 - IF ( J1<1 ) J1 = 1 - RLAT1 = (0.5D0*(DEGLAT(J1)+DEGLAT(JALIM))+90.D0)/RADIAN - ALAT1 = SIN(RLAT1) - DO J = JALIM, JBLIM - J2 = J + 1 - IF ( J2>NLAT ) J2 = NLAT - RLAT2 = (0.5D0*(DEGLAT(J)+DEGLAT(J2))+90.D0)/RADIAN - ALAT2 = SIN(RLAT2) - ALATJ = 0.5D0*(ALAT1+ALAT2)/(RLAT2-RLAT1) - ASUM = ASUM + ALATJ*W1(J) - TSUM = TSUM + ALATJ*W1(J)*ARR(J) - RLAT1 = RLAT2 - ALAT1 = ALAT2 - ENDDO - END SUBROUTINE BOXAV - - SUBROUTINE PHATMO(P,H,D,T,O,Q,S,OCM,WCM,NPHD,NATM) - IMPLICIT NONE -! ------------------------------------------------------------------ -! ------------- MCCLATCHY (1972) ATMOSPHERE DATA ----------- -! ------------------------------------------------------------------ -! -! INPUT DATA -!------------------ -! NATM=0 GIVES ABREVIATED DATA FOR STANDARD ATMOSPHER -! (INPUT: P OR H) (RETURNS: H OR P D,T) -! -! NATM=1 GIVES ATMOSPHERE DATA FOR TROPICAL LATITUDES -! NATM=2 GIVES ATMOSPHERE DATA FOR MIDLATITUDE SUMMER -! NATM=3 GIVES ATMOSPHERE DATA FOR MIDLATITUDE WINTER -! NATM=4 GIVES ATMOSPHERE DATA FOR SUBARCTIC SUMMER -! NATM=5 GIVES ATMOSPHERE DATA FOR SUBARCTIC WINTER -! NATM=6 GIVES ATMOSPHERE DATA FOR STANDARD ATMOSPHER -! -! NPHD=1 RETURNS H,D,T,O,Q,S DATA FOR GIVEN PRESSURE P -! NPHD=2 RETURNS P,D,T,O,Q,S DATA FOR GIVEN HEIGHT H -! NPHD=3 RETURNS P,H,T,O,Q,S DATA FOR GIVEN DENSITY D -! -! OUTPUT DATA -!------------------ -! P = PRESSURE IN MILLIBARS -! H = HEIGHT IN KILOMETERS -! D = DENSITY IN GRAMS/METER**3 -! T = TEMPERATURE (ABSOLUTE) -! O = OZONE MIXING RATIO (GRAMS OZONE)/(GRAMS AIR) -! Q = SPECIFIC HUMIDITY (GRAMS WATER VAPOR)/(GRAMS AIR) -! S = SATURATION RATIO (GRAMS WATER VAPOR)/(GRAMS AIR) -! OCM = OZONE (CM-STP) ABOVE GIVEN HEIGHT -! WCM = WATER VAPOR (CM-STP) ABOVE GIVEN HEIGHT -! -! REMARKS -!------------------ -! INPUT P,H,D PARAMETERS ARE NOT ALTERED -! P,D INTERPOLATION IS EXPONENTIAL WITH HEIGHT -! NO EXTRAPOLATION IS MADE OUTSIDE 0-100 KM INTERVAL -! S IS NOT COMPUTED ABOVE 40 KM (FORMULA NOT ACCURATE) -! -! R = Q/S GIVES RELATIVE HUMIDITY -! W = Q/(1-Q) GIVES WATER VAPOR MIXING RATIO -! N = D*2.079E 16 GIVES NUMBER DENSITY PER CM**3 -! - REAL*8, DIMENSION(33) :: PRS1, PRS2, PRS3, PRS4, PRS5, PRS6, & - DNS1, DNS2, DNS3, DNS4, DNS5, DNS6, & - TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, & - WVP1, WVP2, WVP3, WVP4, WVP5, WVP6, & - OZO1, OZO2, OZO3, OZO4, OZO5, OZO6 - REAL*8, DIMENSION(33,6) :: PRES, DENS, TEMP, WVAP, OZON - - EQUIVALENCE (PRES(1,1),PRS1(1)) - EQUIVALENCE (DENS(1,1),DNS1(1)) - EQUIVALENCE (TEMP(1,1),TMP1(1)) - EQUIVALENCE (PRES(1,2),PRS2(1)) - EQUIVALENCE (DENS(1,2),DNS2(1)) - EQUIVALENCE (TEMP(1,2),TMP2(1)) - EQUIVALENCE (PRES(1,3),PRS3(1)) - EQUIVALENCE (DENS(1,3),DNS3(1)) - EQUIVALENCE (TEMP(1,3),TMP3(1)) - EQUIVALENCE (PRES(1,4),PRS4(1)) - EQUIVALENCE (DENS(1,4),DNS4(1)) - EQUIVALENCE (TEMP(1,4),TMP4(1)) - EQUIVALENCE (PRES(1,5),PRS5(1)) - EQUIVALENCE (DENS(1,5),DNS5(1)) - EQUIVALENCE (TEMP(1,5),TMP5(1)) - EQUIVALENCE (PRES(1,6),PRS6(1)) - EQUIVALENCE (DENS(1,6),DNS6(1)) - EQUIVALENCE (TEMP(1,6),TMP6(1)) - EQUIVALENCE (WVAP(1,1),WVP1(1)) - EQUIVALENCE (OZON(1,1),OZO1(1)) - EQUIVALENCE (WVAP(1,2),WVP2(1)) - EQUIVALENCE (OZON(1,2),OZO2(1)) - EQUIVALENCE (WVAP(1,3),WVP3(1)) - EQUIVALENCE (OZON(1,3),OZO3(1)) - EQUIVALENCE (WVAP(1,4),WVP4(1)) - EQUIVALENCE (OZON(1,4),OZO4(1)) - EQUIVALENCE (WVAP(1,5),WVP5(1)) - EQUIVALENCE (OZON(1,5),OZO5(1)) - EQUIVALENCE (WVAP(1,6),WVP6(1)) - EQUIVALENCE (OZON(1,6),OZO6(1)) - - REAL*8, PARAMETER, DIMENSION(33) & - :: HTKM = (/1D-9,1D0,2D0,3D0,4D0, & - 5D0,6D0,7D0,8D0,9D0,10D0,11D0,12D0, & - 13D0,14D0,15D0,16D0,17D0,18D0,19D0, & - 20D0,21D0,22D0,23D0,24D0,25D0,30D0, & - 35D0,40D0,45D0,50D0,70D0,99.9D0/) - -!---------------------------------------------------------------------- -!0000 GLOBAL U.S. (1976) STANDARD ATMOSPHERE P, T, GEO H PARAMETERS -!---------------------------------------------------------------------- - - REAL*8, PARAMETER, DIMENSION(8) :: SPLB = (/1013.25D0,226.32D0, & - 54.748D0,8.6801D0,1.109D0,.66938D0, & - .039564D0,3.7338D-03/), & - STLB = (/288.15D0,216.65D0,216.65D0, & - 228.65D0,270.65D0,270.65D0,214.65D0, & - 186.87D0/), & - SHLB = (/0D0,11D0,20D0,32D0,47D0, & - 51D0,71D0,84.852D0/), & - SDLB = (/-6.5D0,0D0,1D0,2.8D0,0D0, & - -2.8D0,-2D0,0D0/) - REAL*8, PARAMETER :: HPCON = 34.16319D0 - -!----------------------------------------------------------------------- -!1111 TROPICAL LATITUDES MCCLATCHY (1972) ATMOSPHERE DATA VS HEIGHT -!----------------------------------------------------------------------- - - DATA PRS1/1.013D03, 9.040D02, 8.050D02, 7.150D02, 6.330D02, & - 5.590D02, 4.920D02, 4.320D02, 3.780D02, 3.290D02, 2.860D02, & - 2.470D02, 2.130D02, 1.820D02, 1.560D02, 1.320D02, 1.110D02, & - 9.370D01, 7.890D01, 6.660D01, 5.650D01, 4.800D01, 4.090D01, & - 3.500D01, 3.000D01, 2.570D01, 1.220D01, 6.000D00, 3.050D00, & - 1.590D00, 8.540D-01, 5.790D-02, 3.000D-04/ - DATA DNS1/1.167D03, 1.064D03, 9.689D02, 8.756D02, 7.951D02, & - 7.199D02, 6.501D02, 5.855D02, 5.258D02, 4.708D02, 4.202D02, & - 3.740D02, 3.316D02, 2.929D02, 2.578D02, 2.260D02, 1.972D02, & - 1.676D02, 1.382D02, 1.145D02, 9.515D01, 7.938D01, 6.645D01, & - 5.618D01, 4.763D01, 4.045D01, 1.831D01, 8.600D00, 4.181D00, & - 2.097D00, 1.101D00, 9.210D-02, 5.000D-04/ - DATA TMP1/300.0, 294.0, 288.0, 284.0, 277.0, 270.0, 264.0, 257.0, & - 250.0, 244.0, 237.0, 230.0, 224.0, 217.0, 210.0, 204.0, & - 197.0, 195.0, 199.0, 203., 207.0, 211.0, 215.0, 217.0, 219.0,& - 221.0, 232.0, 243.0, 254.0, 265.0, 270., 219.0, 210.0/ - DATA WVP1/1.9D01, 1.3D01, 9.3D00, 4.7D00, 2.2D00, 1.5D00, 8.5D-01,& - 4.7D-01, 2.5D-01, 1.2D-01, 5.0D-02, 1.7D-02, 6.0D-03, & - 1.8D-03, 1.0D-03, 7.6D-04, 6.4D-04, 5.6D-04, 5.0D-04, & - 4.9D-04, 4.5D-04, 5.1D-04, 5.1D-04, 5.4D-04, 6.0D-04, & - 6.7D-04, 3.6D-04, 1.1D-04, 4.3D-05, 1.9D-05, 6.3D-06, & - 1.4D-07, 1.0D-09/ - DATA OZO1/5.6D-05, 5.6D-05, 5.4D-05, 5.1D-05, 4.7D-05, 4.5D-05, & - 4.3D-05, 4.1D-05, 3.9D-05, 3.9D-05, 3.9D-05, 4.1D-05, & - 4.3D-05, 4.5D-05, 4.5D-05, 4.7D-05, 4.7D-05, 6.9D-05, & - 9.0D-05, 1.4D-04, 1.9D-04, 2.4D-04, 2.8D-04, 3.2D-04, & - 3.4D-04, 3.4D-04, 2.4D-04, 9.2D-05, 4.1D-05, 1.3D-05, & - 4.3D-06, 8.6D-08, 4.3D-11/ - -!----------------------------------------------------------------------- -!2222 MIDLATITUDE SUMMER MCCLATCHY (1972) ATMOSPHERE DATA VS HEIGHT -!----------------------------------------------------------------------- - - DATA PRS2/1.013D03, 9.020D02, 8.020D02, 7.100D02, 6.280D02, & - 5.540D02, 4.870D02, 4.260D02, 3.720D02, 3.240D02, 2.810D02, & - 2.430D02, 2.090D02, 1.790D02, 1.530D02, 1.300D02, 1.110D02, & - 9.500D01, 8.120D01, 6.950D01, 5.950D01, 5.100D01, 4.370D01, & - 3.760D01, 3.220D01, 2.770D01, 1.320D01, 6.520D00, 3.330D00, & - 1.760D00, 9.510D-01, 6.710D-02, 3.000D-04/ - DATA DNS2/1.191D03, 1.080D03, 9.757D02, 8.846D02, 7.998D02, & - 7.211D02, 6.487D02, 5.830D02, 5.225D02, 4.669D02, 4.159D02, & - 3.693D02, 3.269D02, 2.882D02, 2.464D02, 2.104D02, 1.797D02, & - 1.535D02, 1.305D02, 1.110D02, 9.453D01, 8.056D01, 6.872D01, & - 5.867D01, 5.014D01, 4.288D01, 1.322D01, 6.519D00, 3.330D00, & - 1.757D00, 9.512D-01, 6.706D-02, 5.000D-04/ - DATA TMP2/294.0, 290.0, 285.0, 279.0, 273.0, 267.0, 261.0, 255.0, & - 248.0, 242.0, 235.0, 229.0, 222.0, 216.0, 216.0, 216.0, & - 216.0, 216.0, 216.0, 217., 218.0, 219.0, 220.0, 222.0, 223.0,& - 224.0, 234.0, 245.0, 258.0, 270.0, 276., 218.0, 210.0/ - DATA WVP2/1.4D01, 9.3D00, 5.9D00, 3.3D00, 1.9D00, 1.0D00, 6.1D-01,& - 3.7D-01, 2.1D-01, 1.2D-01, 6.4D-02, 2.2D-02, 6.0D-03, & - 1.8D-03, 1.0D-03, 7.6D-04, 6.4D-04, 5.6D-04, 5.0D-04, & - 4.9D-04, 4.5D-04, 5.1D-04, 5.1D-04, 5.4D-04, 6.0D-04, & - 6.7D-04, 3.6D-04, 1.1D-04, 4.3D-05, 1.9D-05, 6.3D-06, & - 1.4D-07, 1.0D-09/ - DATA OZO2/6.0D-05, 6.0D-05, 6.0D-05, 6.2D-05, 6.4D-05, 6.6D-05, & - 6.9D-05, 7.5D-05, 7.9D-05, 8.6D-05, 9.0D-05, 1.1D-04, & - 1.2D-04, 1.5D-04, 1.8D-04, 1.9D-04, 2.1D-04, 2.4D-04, & - 2.8D-04, 3.2D-04, 3.4D-04, 3.6D-04, 3.6D-04, 3.4D-04, & - 3.2D-04, 3.0D-04, 2.0D-04, 9.2D-05, 4.1D-05, 1.3D-05, & - 4.3D-06, 8.6D-08, 4.3D-11/ - -!----------------------------------------------------------------------- -!3333 MIDLATITUDE WINTER MCCLATCHY (1972) ATMOSPHERE DATA VS HEIGHT -!----------------------------------------------------------------------- - - DATA PRS3/1.018D03, 8.973D02, 7.897D02, 6.938D02, 6.081D02, & - 5.313D02, 4.627D02, 4.016D02, 3.473D02, 2.992D02, 2.568D02, & - 2.199D02, 1.882D02, 1.610D02, 1.378D02, 1.178D02, 1.007D02, & - 8.610D01, 7.350D01, 6.280D01, 5.370D01, 4.580D01, 3.910D01, & - 3.340D01, 2.860D01, 2.430D01, 1.110D01, 5.180D00, 2.530D00, & - 1.290D00, 6.820D-01, 4.670D-02, 3.000D-04/ - DATA DNS3/1.301D03, 1.162D03, 1.037D03, 9.230D02, 8.282D02, & - 7.411D02, 6.614D02, 5.886D02, 5.222D02, 4.619D02, 4.072D02, & - 3.496D02, 2.999D02, 2.572D02, 2.206D02, 1.890D02, 1.620D02, & - 1.388D02, 1.188D02, 1.017D02, 8.690D01, 7.421D01, 6.338D01, & - 5.415D01, 4.624D01, 3.950D01, 1.783D01, 7.924D00, 3.625D00, & - 1.741D00, 8.954D-01, 7.051D-02, 5.000D-04/ - DATA TMP3/272.2, 268.7, 265.2, 261.7, 255.7, 249.7, 243.7, 237.7, & - 231.7, 225.7, 219.7, 219.2, 218.7, 218.2, 217.7, 217.2, & - 216.7, 216.2, 215.7, 215.2, 215.2, 215.2, 215.2, 215.2, & - 215.2, 215.2, 217.4, 227.8, 243.2, 258.5, 265.7, 230.7, & - 210.2/ - DATA WVP3/3.5D00, 2.5D00, 1.8D00, 1.2D00, 6.6D-01, 3.8D-01, & - 2.1D-01, 8.5D-02, 3.5D-02, 1.6D-02, 7.5D-03, 6.9D-03, & - 6.0D-03, 1.8D-03, 1.0D-03, 7.6D-04, 6.4D-04, 5.6D-04, & - 5.0D-04, 4.9D-04, 4.5D-04, 5.1D-04, 5.1D-04, 5.4D-04, & - 6.0D-04, 6.7D-04, 3.6D-04, 1.1D-04, 4.3D-05, 1.9D-05, & - 6.3D-06, 1.4D-07, 1.0D-09/ - DATA OZO3/6.0D-05, 5.4D-05, 4.9D-05, 4.9D-05, 4.9D-05, 5.8D-05, & - 6.4D-05, 7.7D-05, 9.0D-05, 1.2D-04, 1.6D-04, 2.1D-04, & - 2.6D-04, 3.0D-04, 3.2D-04, 3.4D-04, 3.6D-04, 3.9D-04, & - 4.1D-04, 4.3D-04, 4.5D-04, 4.3D-04, 4.3D-04, 3.9D-04, & - 3.6D-04, 3.4D-04, 1.9D-04, 9.2D-05, 4.1D-05, 1.3D-05, & - 4.3D-06, 8.6D-08, 4.3D-11/ - -!----------------------------------------------------------------------- -!4444 SUBARCTIC SUMMER MCCLATCHY (1972) ATMOSPHERE DATA VS HEIGHT -!----------------------------------------------------------------------- - - DATA PRS4/1.010D03, 8.960D02, 7.929D02, 7.000D02, 6.160D02, & - 5.410D02, 4.730D02, 4.130D02, 3.590D02, 3.107D02, 2.677D02, & - 2.300D02, 1.977D02, 1.700D02, 1.460D02, 1.250D02, 1.080D02, & - 9.280D01, 7.980D01, 6.860D01, 5.890D01, 5.070D01, 4.360D01, & - 3.750D01, 3.227D01, 2.780D01, 1.340D01, 6.610D00, 3.400D00, & - 1.810D00, 9.870D-01, 7.070D-02, 3.000D-04/ - DATA DNS4/1.220D03, 1.110D03, 9.971D02, 8.985D02, 8.077D02, & - 7.244D02, 6.519D02, 5.849D02, 5.231D02, 4.663D02, 4.142D02, & - 3.559D02, 3.059D02, 2.630D02, 2.260D02, 1.943D02, 1.671D02, & - 1.436D02, 1.235D02, 1.062D02, 9.128D01, 7.849D01, 6.750D01, & - 5.805D01, 4.963D01, 4.247D01, 1.338D01, 6.614D00, 3.404D00, & - 1.817D00, 9.868D-01, 7.071D-02, 5.000D-04/ - DATA TMP4/287.0, 282.0, 276.0, 271.0, 266.0, 260.0, 253.0, 246.0, & - 239.0, 232.0, 225.0, 225.0, 225.0, 225.0, 225.0, 225.0, & - 225.0, 225.0, 225.0, 225., 225.0, 225.0, 225.0, 225.0, 226.0,& - 228.0, 235.0, 247.0, 262.0, 274.0, 277., 216.0, 210.0/ - DATA WVP4/9.1D00, 6.0D00, 4.2D00, 2.7D00, 1.7D00, 1.0D00, 5.4D-01,& - 2.9D-01, 1.3D-02, 4.2D-02, 1.5D-02, 9.4D-03, 6.0D-03, & - 1.8D-03, 1.0D-03, 7.6D-04, 6.4D-04, 5.6D-04, 5.0D-04, & - 4.9D-04, 4.5D-04, 5.1D-04, 5.1D-04, 5.4D-04, 6.0D-04, & - 6.7D-04, 3.6D-04, 1.1D-04, 4.3D-05, 1.9D-05, 6.3D-06, & - 1.4D-07, 1.0D-09/ - DATA OZO4/4.9D-05, 5.4D-05, 5.6D-05, 5.8D-05, 6.0D-05, 6.4D-05, & - 7.1D-05, 7.5D-05, 7.9D-05, 1.1D-04, 1.3D-04, 1.8D-04, & - 2.1D-04, 2.6D-04, 2.8D-04, 3.2D-04, 3.4D-04, 3.9D-04, & - 4.1D-04, 4.1D-04, 3.9D-04, 3.6D-04, 3.2D-04, 3.0D-04, & - 2.8D-04, 2.6D-04, 1.4D-04, 9.2D-05, 4.1D-05, 1.3D-05, & - 4.3D-06, 8.6D-08, 4.3D-11/ - -!----------------------------------------------------------------------- -!5555 SUBARCTIC WINTER MCCLATCHY (1972) ATMOSPHERE DATA VS HEIGHT -!----------------------------------------------------------------------- - - DATA PRS5/1.013D03, 8.878D02, 7.775D02, 6.798D02, 5.932D02, & - 5.158D02, 4.467D02, 3.853D02, 3.308D02, 2.829D02, 2.418D02, & - 2.067D02, 1.766D02, 1.510D02, 1.291D02, 1.103D02, 9.431D01, & - 8.058D01, 6.882D01, 5.875D01, 5.014D01, 4.277D01, 3.647D01, & - 3.109D01, 2.649D01, 2.256D01, 1.020D01, 4.701D00, 2.243D00, & - 1.113D00, 5.719D-01, 4.016D-02, 3.000D-04/ - DATA DNS5/1.372D03, 1.193D03, 1.058D03, 9.366D02, 8.339D02, & - 7.457D02, 6.646D02, 5.904D02, 5.226D02, 4.538D02, 3.879D02, & - 3.315D02, 2.834D02, 2.422D02, 2.071D02, 1.770D02, 1.517D02, & - 1.300D02, 1.113D02, 9.529D01, 8.155D01, 6.976D01, 5.966D01, & - 5.100D01, 4.358D01, 3.722D01, 1.645D01, 7.368D00, 3.330D00, & - 1.569D00, 7.682D-01, 5.695D-02, 5.000D-04/ - DATA TMP5/257.1, 259.1, 255.9, 252.7, 247.7, 240.9, 234.1, 227.3, & - 220.6, 217.2, 217.2, 217.2, 217.2, 217.2, 217.2, 217.2, & - 216.6, 216., 215.4, 214.8, 214.1, 213.6, 213.0, 212.4, 211.8,& - 211.2, 216.0, 222.2, 234.7, 247., 259.3, 245.7, 210.0/ - DATA WVP5/1.2D00, 1.2D00, 9.4D-01, 6.8D-01, 4.1D-01, 2.0D-01, & - 9.8D-02, 5.4D-02, 1.1D-02, 8.4D-03, 5.5D-03, 3.8D-03, & - 2.6D-03, 1.8D-03, 1.0D-03, 7.6D-04, 6.4D-04, 5.6D-04, & - 5.0D-04, 4.9D-04, 4.5D-04, 5.1D-04, 5.1D-04, 5.4D-04, & - 6.0D-04, 6.7D-04, 3.6D-04, 1.1D-04, 4.3D-05, 1.9D-05, & - 6.3D-06, 1.4D-07, 1.0D-09/ - DATA OZO5/4.1D-05, 4.1D-05, 4.1D-05, 4.3D-05, 4.5D-05, 4.7D-05, & - 4.9D-05, 7.1D-05, 9.0D-05, 1.6D-04, 2.4D-04, 3.2D-04, & - 4.3D-04, 4.7D-04, 4.9D-04, 5.6D-04, 6.2D-04, 6.2D-04, & - 6.2D-04, 6.0D-04, 5.6D-04, 5.1D-04, 4.7D-04, 4.3D-04, & - 3.6D-04, 3.2D-04, 1.5D-04, 9.2D-05, 4.1D-05, 1.3D-05, & - 4.3D-06, 8.6D-08, 4.3D-11/ - -!---------------------------------------------------------------------- -!6666 GLOBAL U.S. (1976) STANDARD ATMOSPHERE P, T, GEO H PARAMETERS -!---------------------------------------------------------------------- - - DATA PRS6/1.01325D+03, 8.987D+02, 7.950D+02, 7.011D+02, 6.164D+02,& - 5.402D+02, 4.718D+02, 4.106D+02, 3.560D+02, 3.074D+02, & - 2.644D+02, 2.263D+02, 1.933D+02, 1.651D+02, 1.410D+02, & - 1.204D+02, 1.029D+02, 8.787D+01, 7.505D+01, 6.410D+01, & - 5.475D+01, 4.678D+01, 4.000D+01, 3.422D+01, 2.931D+01, & - 2.511D+01, 1.172D+01, 5.589D+00, 2.775D+00, 1.431D+00, & - 7.594D-01, 4.634D-02, 2.384D-04/ - DATA DNS6/1.225D+03, 1.112D+03, 1.006D+03, 9.091D+02, 8.191D+02, & - 7.361D+02, 6.597D+02, 5.895D+02, 5.252D+02, 4.663D+02, & - 4.127D+02, 3.639D+02, 3.108D+02, 2.655D+02, 2.268D+02, & - 1.937D+02, 1.654D+02, 1.413D+02, 1.207D+02, 1.031D+02, & - 8.803D+01, 7.487D+01, 6.373D+01, 5.428D+01, 4.627D+01, & - 3.947D+01, 1.801D+01, 8.214D+00, 3.851D+00, 1.881D+00, & - 9.775D-01, 7.424D-02, 4.445D-04/ - DATA TMP6/288.150, 281.650, 275.150, 268.650, 262.150, 255.650, & - 249.150, 242.650, 236.150, 229.650, 223.150, 216.650, & - 216.650, 216.650, 216.650, 216.650, 216.650, 216.650, & - 216.650, 216.650, 216.650, 217.650, 218.650, 219.650, & - 220.650, 221.650, 226.650, 237.050, 251.050, 265.050, & - 270.650, 217.450, 186.870/ - DATA WVP6/1.083D+01, 6.323D+00, 3.612D+00, 2.015D+00, 1.095D+00, & - 5.786D-01, 2.965D-01, 1.469D-01, 7.021D-02, 3.226D-02, & - 1.419D-02, 5.956D-03, 5.002D-03, 4.186D-03, 3.490D-03, & - 2.896D-03, 2.388D-03, 1.954D-03, 1.583D-03, 1.267D-03, & - 9.967D-04, 8.557D-04, 7.104D-04, 5.600D-04, 4.037D-04, & - 2.406D-04, 5.404D-05, 2.464D-05, 1.155D-05, 5.644D-06, & - 2.932D-06, 2.227D-07, 1.334D-09/ - DATA OZO6/7.526D-05, 3.781D-05, 6.203D-05, 3.417D-05, 5.694D-05, & - 3.759D-05, 5.970D-05, 4.841D-05, 7.102D-05, 6.784D-05, & - 9.237D-05, 9.768D-05, 1.251D-04, 1.399D-04, 1.715D-04, & - 1.946D-04, 2.300D-04, 2.585D-04, 2.943D-04, 3.224D-04, & - 3.519D-04, 3.714D-04, 3.868D-04, 3.904D-04, 3.872D-04, & - 3.728D-04, 2.344D-04, 9.932D-05, 3.677D-05, 1.227D-05, & - 4.324D-06, 5.294D-08, 1.262D-10/ - - REAL*8, INTENT(INOUT) :: H, P, D - INTEGER, INTENT(IN) :: NATM, NPHD - REAL*8, INTENT(OUT) :: O, Q, S, OCM, WCM, T - REAL*8 :: XX, XI, XJ, DELTA, RAT, PI, PJ, DI, DJ, DP, ES, RS, & - OI, OJ, QI, QJ - INTEGER :: I, J, K, N - - IF ( NATM>0 ) THEN - - IF ( NPHD/=1 ) THEN - IF ( NPHD/=2 ) THEN - XX = D - XI = DENS(1,NATM) - IF ( D>XI ) XX = XI - IF ( D<5.0E-04 ) GOTO 280 - DO J = 2, 33 - XJ = DENS(J,NATM) - IF ( XX>XJ ) GOTO 260 - XI = XJ - ENDDO - ENDIF - XX = H - XI = HTKM(1) - IF ( H99.9 ) GOTO 280 - DO J = 2, 33 - XJ = HTKM(J) - IF ( XXXI ) XX = XI - IF ( P<3.0E-04 ) GOTO 280 - DO J = 2, 33 - XJ = PRES(J,NATM) - IF ( XX>XJ ) EXIT - XI = XJ - ENDDO - ELSE - O = 1.E-10 - Q = 1.E-10 - S = 1.E-10 - OCM = 1.E-10 - WCM = 1.E-10 - IF ( NPHD<2 ) THEN - - DO N = 2, 8 - IF ( P>SPLB(N) ) GOTO 170 - ENDDO - N = 9 - 170 N = N - 1 - IF ( ABS(SDLB(N))<1.E-04 ) THEN - H = SHLB(N) + STLB(N)/HPCON*LOG(SPLB(N)/P) - ELSE - H = SHLB(N) + STLB(N)/SDLB(N) & - *((SPLB(N)/P)**(SDLB(N)/HPCON)-1.) - ENDIF - T = STLB(N) + SDLB(N)*(H-SHLB(N)) - D = P/T*28.9644E05/8.31432E03 - RETURN - ELSE - DO N = 2, 8 - IF ( H1.E-06 ) S = 1./RS - OI = O - QI = Q - OCM = 0.D0 - WCM = 0.D0 - DO K = J, 33 - PJ = PRES(K,NATM) - DJ = DENS(K,NATM) - OJ = OZON(K,NATM)/DJ - QJ = WVAP(K,NATM)/DJ - DP = PI - PJ - OCM = OCM + 0.5D0*(OI+OJ)*DP - WCM = WCM + 0.5D0*(QI+QJ)*DP - OI = OJ - QI = QJ - PI = PJ - ENDDO - WCM = WCM/0.980D0*22420.7D0/18.D0 - OCM = OCM/0.980D0*22420.7D0/48.D0 - RETURN - 280 T = 210.D0 - IF ( NATM==6 ) T = 186.87 - O = 1.D-10 - Q = 1.D-10 - S = 1.D-10 - OCM = 1.D-10 - WCM = 1.D-10 - IF ( NPHD/=1 ) P = 1.D-05 - IF ( NPHD/=2 ) H = 99.99 - IF ( NPHD/=3 ) D = 2.D-05 - END SUBROUTINE PHATMO - - REAL*8 FUNCTION PFOFTK(WAVNA,WAVNB,TK) -! ------------------------------------------------------------------ -! -! INPUT DATA -! WAVNA,WAVNB SPECTRAL INTERVAL IN WAVENUMBERS -! (ORDER OF WAVNA,WAVNB NOT IMPORTANT) -! -! TK ABSOLUTE TEMPERATURE IN DEGREES KELVIN -! -! OUTPUT DATA -! PFofTK PLANCK FLUX (W/m^2) -! -! -! REMARKS -! PLANCK INTENSITY (W/m^2*STER) IS GIVEN BY PFofTK/PI -! -! ------------------------------------------------------------------ - USE CONSTANT, ONLY:stbo ! (W m-2 K-4) Stefan-Boltzmann - IMPLICIT NONE - REAL*8, PARAMETER, DIMENSION(21) & - :: BN = (/1D0,-1D0,1D0,-1D0,1D0, & - -1D0,5D0,-691D0,7D0,-3617D0,43867D0, & - -174611D0,854513D0,-236364091D0, & - 8553103D0,-23749461029D0, & - 8615841276005D0,-7709321041217D0, & - 2577687858367D0,-2631527155305348D4, & - 2929993913841559D0/), & - BD = (/1D0,2D0,6D0,30D0,42D0,30D0, & - 66D0,2730D0,6D0,510D0,798D0,330D0, & - 138D0,2730D0,6D0,870D0,14322D0,510D0,& - 6D0,1919190D0,6D0/) - REAL*8, PARAMETER :: PI4 = 97.40909103400244D0 -! REAL*8, PARAMETER :: PI =3.141592653589793D0 - REAL*8, PARAMETER :: HCK = 1.43879D0 - REAL*8, PARAMETER :: DGXLIM = 1D-06 - - REAL*8, INTENT(IN) :: WAVNA, WAVNB, TK - REAL*8 GSUM, B, DG, DGB, GX, PNORM, GTERM, GXA, GXB, X, XX, XN, & - XN3, XNN, XNM, XNF, XNX - INTEGER II, NB, NNB, N - - PFOFTK = 0D0 - IF ( TK<1D-06 ) RETURN - DO II = 1, 2 - IF ( II==1 ) X = HCK*WAVNA/TK - IF ( II==2 ) X = HCK*WAVNB/TK - IF ( X>2.3D0 ) THEN - GSUM = PI4/15.D0 - DO N = 1, 20 - NNB = N - XN = N - XNN = XN*XN - XNX = XN*X - IF ( XNX>100.D0 ) EXIT - GTERM = (X*X*(3.D0+XNX)+6.D0*(1.D0+XNX)/XNN)/XNN - DG = GTERM*EXP(-XNX) - GSUM = GSUM - DG - DGB = DG - IF ( DG2.0D0 ) THEN - XC = XX - YC = YY - DO - XA = XB - YA = YB - XB = XB*2.D0 - YB = PFOFTK(WAVNA,WAVNB,XB) - IF ( YB>YC ) GOTO 190 - IF ( YB>=PF ) THEN - XC = XB - YC = YB - GOTO 190 - ENDIF - ENDDO - ELSEIF ( XX>XB ) THEN - XC = XX - YC = YY - ELSE - XC = XB - YC = YB - XB = XX - YB = YY - ENDIF - 120 DO - XBA = XB - XA - XCA = XC - XA - XBC = XB - XC - YBA = YB - YA - YCA = YC - YA - YBC = YB - YC - NFIT = NFIT + 1 - IF ( NFIT>NMAX ) THEN - TKOFPF = XX - GOTO 99999 - ELSE - YXBA = YBA/XBA - YXCA = YCA/XCA - C = (YXBA-YXCA)/XBC - B = YXBA - (XB+XA)*C - A = YA - XA*(B+XA*C) - ROOT = SQRT(B*B+4.D0*C*(PF-A)) - XX = 0.5D0*(ROOT-B)/C - IF ( XXXC ) XX = -0.5D0*(ROOT+B)/C - YY = PFOFTK(WAVNA,WAVNB,XX) - IF ( LOGFIT ) YY = LOG(YY) - IF ( ABS(YY-PF)XB ) THEN - XA = XB - YA = YB - ELSE - XC = XB - YC = YB - ENDIF - XB = XX - YB = YY - ENDIF - ENDIF - ENDDO - 190 XB = XA + (PF-YA)*(XC-XA)/(YC-YA) - YB = PFOFTK(WAVNA,WAVNB,XB) - XX = XB - IF ( ABS(YB-PF)NXF ) THEN - SELECT CASE (oper) - CASE ('repart') - GYL(J) = SUMG - CASE ('interp') - GYL(J) = SUMG/SUMY - ENDSELECT - DO - J = J + 1 - IF ( J>NYG ) GOTO 160 - GYL(J) = 0.D0 - ENDDO - ELSE - XA = XB - XB = XLB(I+1) - ENDIF - ELSE - PART = (YB-XAYA)/(XB-XA) - SUMG = SUMG + PART*FXL(I) - SUMY = SUMY + PART - SELECT CASE (oper) - CASE ('repart') - GYL(J) = SUMG - CASE ('interp') - GYL(J) = SUMG/SUMY - ENDSELECT - J = J + 1 - IF ( J>NYG ) GOTO 160 - SUMG = 0.D0 - SUMY = 0.D0 - YA = YB - YB = YLB(J+1) - ENDIF - ENDDO - ELSE - I = I + 1 - IF ( I>NXF ) GOTO 160 - XA = XB - ENDIF - ENDDO - ELSE - GYL(J) = 0.D0 - J = J + 1 - IF ( J>NYG ) EXIT - YA = YB - ENDIF - ENDDO - ELSE - DO - YB = YLB(J+1) - IF ( YB>XA ) THEN - DO - XB = XLB(I+1) - IF ( XB>YA ) THEN - DO - XAYA = XA - IF ( YA>XA ) XAYA = YA - IF ( YB>XB ) THEN - PART = (XB-XAYA)/(XB-XA) - SUMG = SUMG + PART*FXL(I) - SUMY = SUMY + PART - I = I + 1 - IF ( I>NXF ) THEN - SELECT CASE (oper) - CASE ('repart') - GYL(J) = SUMG - CASE ('interp') - GYL(J) = SUMG/SUMY - ENDSELECT - DO - J = J + 1 - IF ( J>NYG ) GOTO 160 - GYL(J) = 0.D0 - ENDDO - ELSE - XA = XB - XB = XLB(I+1) - ENDIF - ELSE - PART = (YB-XAYA)/(XB-XA) - SUMG = SUMG + PART*FXL(I) - SUMY = SUMY + PART - SELECT CASE (oper) - CASE ('repart') - GYL(J) = SUMG - CASE ('interp') - GYL(J) = SUMG/SUMY - ENDSELECT - J = J + 1 - IF ( J>NYG ) GOTO 160 - SUMG = 0.D0 - SUMY = 0.D0 - YA = YB - YB = YLB(J+1) - ENDIF - ENDDO - ELSE - I = I + 1 - IF ( I>NXF ) GOTO 160 - XA = XB - ENDIF - ENDDO - ELSE - GYL(J) = 0.D0 - J = J + 1 - IF ( J>NYG ) EXIT - YA = YB - ENDIF - ENDDO - ENDIF - - 160 END SUBROUTINE REPARTINT - - SUBROUTINE FABINT(F,X,NX,ALIM,BLIM,ABINT) - IMPLICIT NONE -! ------------------------------------------------------------------ -! FABINT PERFORMS NUMERICAL INTEGRATION (AREA UNDER CURVE) OF F(X) -! BETWEEN THE LIMITS X=ALIM AND X=BLIM (WITH BLIM GT ALIM) -! -! F(X) IS DEFINED BY CONNECTING SUCCESSIVE F(X) DATA POINTS USING -! STRAIGHT-LINE SEGMENTS, I.E. F(X) IS PIECE-WISE CONTINUOUS -! THE X COORDINATE CAN BE IN ASCENDING OR DESCENDING ORDER -! -! (F(X) IS ZERO OUTSIDE THE INTERVAL BETWEEN X(1) AND X(NX)) -! ------------------------------------------------------------------ - INTEGER, INTENT(IN) :: NX - REAL*8, INTENT(IN) :: F(NX), X(NX), ALIM, BLIM - REAL*8, INTENT(OUT) :: ABINT - REAL*8, PARAMETER :: DELTA = 1.D-07 - REAL*8 XA, XB, XX, XMIN, XMAX, XJ, XI, FI, FJ, BF, AF, DINT, X2, & - X1 - INTEGER JX, KX, IX - - ABINT = 0.D0 - JX = 1 - KX = 1 - XA = X(JX) - XB = X(NX) - XX = XA - IF ( XB<=XA ) THEN - XA = XB - XB = XX - JX = NX - KX = -1 - ENDIF - XMIN = XA - XMAX = XB - IF ( XMIN>=BLIM ) RETURN - IF ( XMAX<=ALIM ) RETURN - IF ( XMINBLIM ) XMAX = BLIM - DO - JX = JX + KX - XJ = X(JX) - IF ( XJ>XMIN ) THEN - IX = JX - KX - XI = X(IX) - IF ( (XJ-XI)>=DELTA ) THEN - FI = F(IX) - FJ = F(JX) - BF = (FJ-FI)/(XJ-XI) - AF = FJ - BF*XJ - X2 = XMIN - DO - X1 = X2 - X2 = XJ - IF ( X2>XMAX ) X2 = XMAX - DINT = AF*(X2-X1) + BF*(X2**2-X1**2)/2.D0 - ABINT = ABINT + DINT - IF ( DABS(X2-XMAX)=DELTA ) THEN - BF = (FJ-FI)/(XJ-XI) - AF = FJ - BF*XJ - EXIT - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - ENDIF - ENDDO - END SUBROUTINE FABINT - - SUBROUTINE FXGINT(F,X,NX,G,Y,NY,ALIM,BLIM,ABINT) - IMPLICIT NONE -! ------------------------------------------------------------------ -! FXGINT PERFORMS NUMERICAL INTEGRATION (AREA UNDER CURVE) OF F*G -! BETWEEN THE LIMITS X=ALIM AND X=BLIM (WITH BLIM GT ALIM) -! -! F(X) IS DEFINED BY CONNECTING SUCCESSIVE F(X) DATA POINTS USING -! STRAIGHT-LINE SEGMENTS, I.E. F(X) IS PIECE-WISE CONTINUOUS -! THE X COORDINATE CAN BE IN ASCENDING OR DESCENDING ORDER -! -! G(Y) IS DEFINED BY CONNECTING SUCCESSIVE G(Y) DATA POINTS USING -! STRAIGHT-LINE SEGMENTS, I.E. G(Y) IS PIECE-WISE CONTINUOUS -! THE Y COORDINATE CAN BE IN ASCENDING OR DESCENDING ORDER -! -! (X,Y ARE THE SAME LINEAR COORDINATE INDEPENDENTLY DEFINED) -! -! (F(X) IS ZERO OUTSIDE THE INTERVAL BETWEEN X(1) AND X(NX)) -! (G(Y) IS ZERO OUTSIDE THE INTERVAL BETWEEN Y(1) AND Y(NY)) -! ------------------------------------------------------------------ - INTEGER, INTENT(IN) :: NX, NY - REAL*8, INTENT(IN) :: F(NX), X(NX), G(NY), Y(NY), ALIM, BLIM - REAL*8, INTENT(OUT) :: ABINT - REAL*8, PARAMETER :: DELTA = 1.D-07 - REAL*8 XA, YA, XB, YB, XX, XMIN, XMAX, XJ, XI, FI, FJ, BF, AF, YI,& - YJ, GI, GJ, AG, BG, DINT, X2, X1 - INTEGER JX, JY, KX, KY, IX, IY - - ABINT = 0.D0 - JX = 1 - JY = 1 - KX = 1 - KY = 1 - XA = X(JX) - YA = Y(JY) - XB = X(NX) - YB = Y(NY) - XX = XA - IF ( XB<=XA ) THEN - XA = XB - XB = XX - JX = NX - KX = -1 - ENDIF - XX = YA - IF ( YB<=YA ) THEN - YA = YB - YB = XX - JY = NY - KY = -1 - ENDIF - XMIN = MAX(XA,YA) - XMAX = MIN(XB,YB) - IF ( XMIN>=BLIM ) RETURN - IF ( XMAX<=ALIM ) RETURN - IF ( XMINBLIM ) XMAX = BLIM - DO - JX = JX + KX - XJ = X(JX) - IF ( XJ>XMIN ) THEN - IX = JX - KX - XI = X(IX) - IF ( (XJ-XI)>=DELTA ) THEN - FI = F(IX) - FJ = F(JX) - BF = (FJ-FI)/(XJ-XI) - AF = FJ - BF*XJ - DO - JY = JY + KY - YJ = Y(JY) - IF ( YJ>XMIN ) THEN - IY = JY - KY - YI = Y(IY) - IF ( (YJ-YI)>=DELTA ) THEN - GI = G(IY) - GJ = G(JY) - BG = (GJ-GI)/(YJ-YI) - AG = GJ - BG*YJ - X2 = XMIN - GOTO 160 - ENDIF - ENDIF - ENDDO - ENDIF - ENDIF - ENDDO - 160 X1 = X2 - X2 = MIN(XJ,YJ) - IF ( X2>XMAX ) X2 = XMAX - DINT = (AF*AG)*(X2-X1) + (AF*BG+BF*AG)*(X2**2-X1**2) & - /2.D0 + (BF*BG)*(X2**3-X1**3)/3.D0 - ABINT = ABINT + DINT - IF ( DABS(X2-XMAX)=DELTA ) THEN - BF = (FJ-FI)/(XJ-XI) - AF = FJ - BF*XJ - EXIT - ENDIF - ENDDO - ENDIF - DO WHILE ( YJ<=X2 ) - YI = YJ - GI = GJ - IY = JY - JY = JY + KY - YJ = Y(JY) - GJ = G(JY) - IF ( DABS(YJ-YI)>=DELTA ) THEN - BG = (GJ-GI)/(YJ-YI) - AG = GJ - BG*YJ - EXIT - ENDIF - ENDDO - GOTO 160 - END SUBROUTINE FXGINT - - SUBROUTINE CTREND(JYEAR,IDEC,JDEC,CWTI,CWTJ) - IMPLICIT NONE - -!------------------------------------------------------------------- -! Black Carbon interdecadal TAU interpolation is based on linear -! TAU trend (between decadal global TAUmaps) with a superimposed -! intra-decadal time dependence scaled to the Black Carbon Total -! emission rate. -! -! INPUT: JYEAR (Julian year) -! -! CTREND coefficients refer to sep2003_OCI_Koch maps -! CTREND coefficients refer to sep2003_BCI_Koch maps -! -------------------------------------------------- -! -! Map= 1850 1875 1900 1925 1950 1960 1970 1980 1990 -! OUTPUT: IDEC= (0) 1 2 3 4 5 6 7 8 -! JDEC= IDEC + 1 (returned IDEC,JDEC are (1 to 8) -! -! CWTI= (Multiplicative Weight for BC DataMap IDEC) -! CWTJ= (Multiplicative Weight for BC DataMap JDEC) -! -! NOTE: Time dependence is linear before 1950. Industrial BC -! is assumed 0 in 1850 so CWTI=0, and IDEC is set to 1 -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: JYEAR - INTEGER, INTENT(OUT) :: IDEC, JDEC - REAL*8, INTENT(OUT) :: CWTI, CWTJ - -! Global Annual Emissions of BC U Emission (Mt/yr) - -! Year Hard_Coal Brown_Coal Diesel Total - REAL*8, PARAMETER, DIMENSION(5,45) :: BCE = RESHAPE((/50.0, & - 2.280581713,0.4449132979, & - 0.1599090248,2.885536671,51.0, & - 2.443193913,0.4855868816, & - 0.1884280443,3.117194653,52.0, & - 2.473641872,0.5115299225, & - 0.2027695477,3.187930107,53.0, & - 2.481340885,0.5448409319, & - 0.2149295360,3.241089582,54.0, & - 2.505670071,0.5780177116, & - 0.2343477309,3.317960978,55.0, & - 2.698692560,0.6238067150, & - 0.2733324766,3.595800638,56.0, & - 2.855226278,0.6531309485, & - 0.3043369055,3.812692404,57.0, & - 2.975781679,0.6821750998, & - 0.3207367063,3.978575468,58.0, & - 3.341105223,0.7035279870, & - 0.3370627165,4.381746292,59.0, & - 3.638528824,0.7075053453, & - 0.3695519567,4.715488434,60.0, & - 3.770926714,0.7416650057, & - 0.3832504749,4.896034241,61.0, & - 3.392980337,0.7805693150, & - 0.4217525721,4.595387459,62.0, & - 3.288835049,0.8179932237, & - 0.4603823125,4.567360401,63.0, & - 3.359177589,0.8604368567, & - 0.5090782642,4.728550911,64.0, & - 3.432664871,0.8952696323, & - 0.5388473868,4.866865158,65.0, & - 3.529418945,0.8819132447, & - 0.5785927773,4.989773750,66.0, & - 3.577459812,0.8817394972, & - 0.6323299408,5.091631413,67.0, & - 3.418204546,0.8635972142, & - 0.6592246890,4.941041946,68.0, & - 3.452457905,0.8943673372, & - 0.7338049412,5.080585003,69.0, & - 3.626069546,0.9298774004, & - 0.7889106274,5.344810009,70.0, & - 3.264039755,0.9229136109, & - 0.8880128860,5.074741840,71.0, & - 3.437611580,0.9374827743, & - 0.9531223178,5.328329086,72.0, & - 3.473345757,0.7836616039, & - 1.0180075170,5.274850368,73.0, & - 3.495583296,0.8056778908, & - 1.1174367670,5.418928623,74.0, & - 3.506143808,0.8251076341, & - 1.0828053950,5.413989067,75.0, & - 3.906814098,0.8527192473, & - 1.0454736950,5.804963112,76.0, & - 4.005736828,0.8900613785, & - 1.1400985720,6.035901546,77.0, & - 4.236912251,0.9103702307, & - 1.2190728190,6.366260529,78.0, & - 4.459666252,0.9303293228, & - 1.2408012150,6.630728722,79.0, & - 4.697422504,0.9856286645, & - 1.3019220830,6.984815121,80.0, & - 4.796229839,0.9959300756, & - 1.2336660620,7.026207924,81.0, & - 4.789204121,1.0459070210, & - 1.1664049630,7.001126766,82.0, & - 4.872739315,1.0975246430, & - 1.1601715090,7.130136490,83.0, & - 4.983223438,1.1424025300, & - 1.1732926370,7.298912525,84.0, & - 5.265352249,1.2178678510, & - 1.2251536850,7.708741188,85.0, & - 5.763637543,1.2965050940, & - 1.2428865430,8.303324699,86.0, & - 5.924767494,1.3386499880, & - 1.2930148840,8.556744576,87.0, & - 6.155550480,1.3738890890, & - 1.3162037130,8.845513344,88.0, & - 6.379704475,1.3670797350, & - 1.3813229800,9.127896309,89.0, & - 6.594299316,1.4169263840, & - 1.4029121400,9.414231300,90.0, & - 6.566919804,1.4685817960, & - 1.4224120380,9.458042145,91.0, & - 6.661097050,1.2067918780, & - 1.4163945910,9.284657478,92.0, & - 7.737902641,1.3509917260, & - 1.4471185210,10.53625107,93.0, & - 7.393332005,1.2448183300, & - 1.4543261530,10.09271908,94.0, & - 7.515841007,1.2333894970, & - 1.4780857560,10.22745800/),(/5,45/)) - - REAL*8 XDEC - INTEGER IBCDEC, JBCDEC, IJYEAR - - IF ( JYEAR<1876 ) THEN - CWTJ = (JYEAR-1850)/25.D0 - IF ( CWTJ<0.D0 ) CWTJ = 0.D0 - CWTI = 0.D0 - IDEC = 1 - JDEC = 1 - GOTO 100 - ENDIF - - IF ( JYEAR<1950 ) THEN - XDEC = (JYEAR-1850)/25.D0 - IDEC = XDEC - JDEC = IDEC + 1 - CWTJ = XDEC - IDEC - CWTI = 1.D0 - CWTJ - GOTO 100 - ENDIF - - IF ( JYEAR<1990 ) THEN - IDEC = (JYEAR-1910)/10 - JDEC = IDEC + 1 - IBCDEC = 1 + (IDEC-4)*10 - JBCDEC = IBCDEC + 10 - IJYEAR = JYEAR - 1949 - CWTJ = (BCE(5,IJYEAR)-BCE(5,IBCDEC)) & - /(BCE(5,JBCDEC)-BCE(5,IBCDEC)) - CWTI = 1.D0 - CWTJ - GOTO 100 - ENDIF - - IF ( JYEAR>1989 ) THEN - IDEC = 7 - JDEC = 8 - IJYEAR = JYEAR - 1949 - IF ( IJYEAR>45 ) IJYEAR = 45 - CWTJ = BCE(5,IJYEAR)/BCE(5,41) - CWTI = 0.D0 - ENDIF - - 100 END SUBROUTINE CTREND - - SUBROUTINE STREND(JYEAR,IDEC,JDEC,SWTI,SWTJ) - IMPLICIT NONE - -!------------------------------------------------------------------- -! Anthropogenic Sulfate inter-decadal TAU interpolation is based -! on a linear TAU trend (between decadal global TAU-maps) with a -! superimposed intradecadal time dependence scaled in proportion -! to the Anthropogenic Sulfate global emission rate. -! -! INPUT: JYEAR (Julian year) -! -! CTREND coefficients refer to sep2003_SUI_Koch maps -! -------------------------------------------------- -! -! Map= 1850 1875 1900 1925 1950 1960 1970 1980 1990 -! OUTPUT: IDEC= (0) 1 2 3 4 5 6 7 8 -! JDEC= IDEC + 1 (returned IDEC,JDEC are (1 to 8) -! -! SWTI= (Multiplicative Weight for SUI DataMap IDEC) -! SWTJ= (Multiplicative Weight for SUI DataMap JDEC) -! -! NOTE: Time dependence linear before 1950. Industrial SUI -! is assumed 0 in 1850 so SWTI=0, and IDEC is set to 1 -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: JYEAR - INTEGER, INTENT(OUT) :: IDEC, JDEC - REAL*8, INTENT(OUT) :: SWTI, SWTJ - -! Global Emission of Sulfate - -! Emission (Mt/yr) -! year Anthropogenic_Sulfate Natural_Sulfate - REAL*8, PARAMETER, DIMENSION(3,41) :: SUE = RESHAPE((/1950.0, & - 30.46669769,14.4,1951.0,32.38347244, & - 14.4,1952.0,32.18632889,14.4,1953.0, & - 32.83379745,14.4,1954.0,32.79270935, & - 14.4,1955.0,35.79611969,14.4,1956.0, & - 39.93603897,14.4,1957.0,38.68806839, & - 14.4,1958.0,39.35904312,14.4,1959.0, & - 41.06065369,14.4,1960.0,42.67050934, & - 14.4,1961.0,41.32410431,14.4,1962.0, & - 41.80470276,14.4,1963.0,43.26312637, & - 14.4,1964.0,44.68368530,14.4,1965.0, & - 45.81701660,14.4,1966.0,46.61584091, & - 14.4,1967.0,46.42276001,14.4,1968.0, & - 47.77438354,14.4,1969.0,49.30817032, & - 14.4,1970.0,52.81050873,14.4,1971.0, & - 52.95043945,14.4,1972.0,54.10167694, & - 14.4,1973.0,55.93037415,14.4,1974.0, & - 57.31056213,14.4,1975.0,58.52788162, & - 14.4,1976.0,59.71361542,14.4,1977.0, & - 62.59599304,14.4,1978.0,61.98198318, & - 14.4,1979.0,64.71042633,14.4,1980.0, & - 65.28986359,14.4,1981.0,63.23768234, & - 14.4,1982.0,62.88000488,14.4,1983.0, & - 61.45023346,14.4,1984.0,63.85008621, & - 14.4,1985.0,66.47412872,14.4,1986.0, & - 68.00902557,14.4,1987.0,69.87956238, & - 14.4,1988.0,70.52937317,14.4,1989.0, & - 72.06355286,14.4,1990.0,71.29174805, & - 14.4/),(/3,41/)) - - REAL*8 xdec - INTEGER ISUDEC, JSUDEC, IJYEAR - - IF ( JYEAR<1876 ) THEN - SWTJ = (JYEAR-1850)/25.D0 - IF ( SWTJ<0.D0 ) SWTJ = 0.D0 - SWTI = 0.D0 - IDEC = 1 - JDEC = 1 - GOTO 100 - ENDIF - - IF ( JYEAR<1950 ) THEN - XDEC = (JYEAR-1850)/25.D0 - IDEC = XDEC - JDEC = IDEC + 1 - SWTJ = XDEC - IDEC - SWTI = 1.D0 - SWTJ - GOTO 100 - ENDIF - - IF ( JYEAR<1990 ) THEN - IDEC = (JYEAR-1910)/10 - JDEC = IDEC + 1 - ISUDEC = 1 + (IDEC-4)*10 - JSUDEC = ISUDEC + 10 - IJYEAR = JYEAR - 1949 - SWTJ = (SUE(2,IJYEAR)-SUE(2,ISUDEC)) & - /(SUE(2,JSUDEC)-SUE(2,ISUDEC)) - SWTI = 1.D0 - SWTJ - GOTO 100 - ENDIF - - IF ( JYEAR>1989 ) THEN - IDEC = 7 - JDEC = 8 - IJYEAR = JYEAR - 1949 - IF ( IJYEAR>41 ) IJYEAR = 41 - SWTJ = SUE(2,IJYEAR)/SUE(2,41) - SWTI = 0.D0 - ENDIF - - 100 END SUBROUTINE STREND - - SUBROUTINE SPLINV(X,F,NXF,XX,FF,CUSPWM,CUSPWE,KXTRAP) - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NXF, KXTRAP - REAL*8, INTENT(IN) :: X(NXF), F(NXF), FF, CUSPWM, CUSPWE - REAL*8, INTENT(OUT) :: XX - -!--------------------------------------------------------------------- -! Inverse spline: -! SPLINV locates FF between points (F2,X2)(F3,X3) on 4-point spread -! and returns 4-point Cubic Spline value of XX such that FF = F(XX) -! -! Quadratic Derivatives of Spline are continuous at (F2,X2),(F3,X3) -! (X-Coordinate may be specified in increasing or decreasing order) -! -!--------------------------------------------------------------------- -! -! Custom Control Parameters: CUSPWM,CUSPWE -!------------------------------ -! -! In cases where data points are unevenly spaced and/or data points -! exhibit abrupt changes in value, Spline Interpolation may produce -! undesirable bulging of interpolated values. In more extreme cases -! Linear Interpolation may be less problematic to use. -! -! Interpolation can be weighted between: Cubic Spline and Linear by -! adjusting weights CUSPWM and CUSPWE to values between 1.0 and 0.0 -! -! CUSPWM = Cubic Spline Weight at the (X2-X3) Interval Mid-point -! CUSPWE = Cubic Spline Weight at the (X2-X3) Interval End-points -! -! For example, with: -! -! CUSPWM=1.0,CUSPWE=1.0 FF returns Cubic Spline interpolated value -! CUSPWM=0.0,CUSPWE=0.0 FF returns Linearly interpolated value -! -!--------------------------------------------------------------------- -! -! Extrapolation for XX outside of defined interval: X(1)<->X(NXF) -! -! KXTRAP = 0 No Extrapolation (i.e., sets XX = 0.0) -! 1 Fixed Extrapolation (sets XX=edge value) -! 2 Linear Extrapolation using 2 edge points -! -!--------------------------------------------------------------------- -! -! -! NOTE: F(X) is assumed to be monotonic between F(1) and F(NXF) -! -!------------------------------------------------------------------ - - REAL*8 x1, x2, x3, x4, x21, x32, x43, x31, x42, BETW, FFCUSP, & - FFLINR, CUSPWT - REAL*8 f1, f2, f3, f4, f21, f32, f43, f3221, f4332, a, b, c, d, & - xf, xe, xexm - REAL*8 DX, gg, xg, xy, deltx, slopec, slopel, slopes - INTEGER k, kk - - BETW = (F(2)-FF)*(F(NXF)-F(1)) - IF ( BETW>0.D0 ) THEN - -! Edge Point Interval Interpolation and/or Extrapolation -! ------------------------------------------------------ - BETW = (F(1)-FF)*(F(NXF)-F(1)) - IF ( BETW>0.D0 ) THEN - -! Extrapolation for FF Outside of Interval F(1) - F(2) -! ---------------------------------------------------- -! IF(KXTRAP == 0) (No Extrapolation: sets XX = 0.0) -! IF(KXTRAP == 1) (Extrapolation at Fixed Edge Value) -! IF(KXTRAP == 2) (2 Edge Point Linear Extrapolation) - - IF ( KXTRAP==0 ) XX = 0.D0 - IF ( KXTRAP==1 ) XX = X(1) - IF ( KXTRAP==2 ) XX = X(1) - (F(1)-FF)/(F(2)-F(1)) & - *(X(2)-X(1)) - ELSE - -! F(1),F(2) Edge Point Interval Interpolation -! -------------------------------------------- - DO KK = 2, 6 - X1 = X(1) - X2 = X(2) - X3 = X(3) - F1 = F(1) - F2 = F(2) - F3 = F(3) - XX = X1 + (FF-F(1))/(F(2)-F(1))*(X2-X1) - XF = XX - X1 - X21 = X2 - X1 - F21 = (F2-F1)/X21 - X32 = X3 - X2 - X31 = X3 - X1 - C = ((F3-F2)/X32-F21)/X31 - B = F21 - X21*C - A = F1 - FFCUSP = A + XF*(B+XF*C) - FFLINR = A + XF*F21 - XE = 1.D0 - 2.D0*XF/X21 - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - GG = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - SLOPEC = B + 2.D0*C*XF - SLOPEL = F21 - SLOPES = SLOPEC*CUSPWT + SLOPEL*(1.D0-CUSPWT) - XG = XF - DELTX = (GG-FF)/SLOPES - XX = XF - (GG-FF)/SLOPES + X1 - ENDDO - ENDIF - ELSE - BETW = (FF-F(NXF-1))*(F(NXF)-F(1)) - IF ( BETW>0.D0 ) THEN - - BETW = (FF-F(NXF))*(F(NXF)-F(1)) - IF ( BETW>0.D0 ) THEN - -! Extrapolation for F Outside of Interval F(NXF-1)-F(NXF) -! -------------------------------------------------------- -! IF(KXTRAP == 0) (No Extrapolation: sets XX = 0.0) -! IF(KXTRAP == 1) (Extrapolation at Fixed Edge Value) -! IF(KXTRAP == 2) (2 Edge Point Linear Extrapolation) - - IF ( KXTRAP==0 ) XX = 0.D0 - IF ( KXTRAP==1 ) XX = X(NXF) - IF ( KXTRAP==2 ) XX = X(NXF) - (F(NXF)-FF) & - /(F(NXF-1)-F(NXF)) & - *(X(NXF-1)-X(NXF)) - ELSE - -! F(NXF-1),F(NXF) Edge Point Interval Interpolation -! -------------------------------------------------- - DO KK = 3, 7 - X1 = X(NXF-2) - X2 = X(NXF-1) - X3 = X(NXF) - F1 = F(NXF-2) - F2 = F(NXF-1) - F3 = F(NXF) - XX = X2 + (FF-F2)/(F3-F2)*(X3-X2) - XF = XX - X2 - X32 = X3 - X2 - F32 = (F3-F2)/X32 - X21 = X2 - X1 - X31 = X3 - X1 - F21 = (F2-F1)/X21 - -! 3-Point Quadratic Interpolation for Edge Intervals -! -------------------------------------------------- -! -! (Edge Option) ---------------------------------------------- -! For Linear Interpolation within Edge Intervals -! between F(1),F(2), and between F(NXF-1),F(NXF) -! set the value of coefficient C below, to C=0.0 -! ---------------------------------------------- - - C = (F32-F21)/X31 - B = F21 + X21*C - A = F2 - FFCUSP = A + XF*(B+XF*C) - FFLINR = A + XF*F32 - XE = 1.D0 - 2.D0*XF/X32 - IF ( XE<0.D0 ) XE = -XE - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - GG = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - SLOPEC = B + 2.D0*C*XF - SLOPEL = F21 - SLOPES = SLOPEC*CUSPWT + SLOPEL*(1.D0-CUSPWT) - XG = XF - DELTX = (GG-FF)/SLOPES - XX = XF - (GG-FF)/SLOPES + X2 - ENDDO - ENDIF - ELSE - - DO K = 3, NXF - 1 - BETW = (FF-F(K-1))*(F(K)-FF) - DX = (FF-F(K-1))/(F(K)-F(K-1)) - XX = X(K-1) + DX*(X(K)-X(K-1)) - IF ( BETW>=0.D0 ) EXIT - ENDDO - - DO KK = 1, 5 - X1 = X(K-2) - X2 = X(K-1) - X3 = X(K) - X4 = X(K+1) - F1 = F(K-2) - F2 = F(K-1) - F3 = F(K) - F4 = F(K+1) - X21 = X2 - X1 - X31 = X3 - X1 - X32 = X3 - X2 - X43 = X4 - X3 - X42 = X4 - X2 - F21 = (F2-F1)/(X21*X21) - F32 = (F3-F2)/(X32*X32) - F43 = (F4-F3)/(X43*X43) - F3221 = (F32+F21)/X31*X21 - F4332 = (F43+F32)/X42*X43 - A = F2 - B = X32*F3221 - C = 3.D0*F32 - F3221 - F3221 - F4332 - D = (F3221+F4332-F32-F32)/X32 - XF = XX - X2 - -! FFCUSP= Cubic Spline Interpolation Result -! ----------------------------------------- - - FFCUSP = A + XF*(B+XF*(C+XF*D)) - XE = (X3+X2-XX-XX)/X32 - IF ( XE<0.D0 ) XE = -XE - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - -! FFLINR= Linear Interpolation Result -! ----------------------------------- - FFLINR = A + XF*F32*X32 - GG = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - SLOPEC = B + 2.D0*C*XF + 3.D0*D*XF**2 - SLOPEL = F32*X32 - SLOPES = SLOPEC*CUSPWT + SLOPEL*(1.D0-CUSPWT) - XG = XF - XY = XX - DELTX = (GG-FF)/SLOPES - XX = XF - (GG-FF)/SLOPES + X2 - ENDDO - ENDIF - ENDIF - - END SUBROUTINE SPLINV - - SUBROUTINE THREEPTQUADINTERPOLATION(NVEC,X21,X31,X32,XF,CUSPWM, & - CUSPWE,F21,F32,F2,FF) - IMPLICIT NONE - INTEGER, INTENT(IN) :: NVEC - REAL*8, INTENT(IN) :: X21, X31, X32, XF, CUSPWM, CUSPWE - REAL*8, DIMENSION(NVEC), INTENT(IN) :: F32, F21, F2 - REAL*8, INTENT(OUT) :: FF(NVEC) - -! 3-Point Quadratic Interpolation for Edge Intervals -! -------------------------------------------------- -! -! (Edge Option) ---------------------------------------------- -! For Linear Interpolation within Edge Intervals -! between X(1),X(2), and between X(NXF-1),X(NXF) -! set the value of coefficient C below, to C=0.0 -! ---------------------------------------------- - INTEGER :: K - REAL*8 :: A, B, C, FFCUSP, XE, XEXM, CUSPWT, FFLINR - - DO K = 1, NVEC - C = (F32(K)-F21(K))/X31 - B = F21(K) + X21*C - A = F2(K) - FFCUSP = A + XF*(B+XF*C) - FFLINR = A + XF*F32(K) - XE = 1.D0 - 2.D0*XF/X32 - IF ( XE<0.D0 ) XE = -XE - XEXM = XE**2 - CUSPWT = (1.D0-XEXM)*CUSPWM + XEXM*CUSPWE - FF(K) = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - ENDDO - END SUBROUTINE THREEPTQUADINTERPOLATION - - SUBROUTINE SPLN44(Q,NI,NJ,IR,DR,JN,DN,QQ) - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NI, NJ, IR, JN - REAL*8, INTENT(IN) :: Q(NI,NJ), DR, DN - REAL*8, INTENT(OUT) :: QQ - -!nu REAL*8,save :: CUSPWM=1., CUSPWE=1. ,CUSPWT,fflinr - REAL*8 QK(4) - REAL*8 f1, f2, f3, f4 - INTEGER k, kr, irm, irp - REAL*8, EXTERNAL :: COMPUTE2 - - K = 0 - IRM = IR - 1 - IRP = IR + 2 - DO KR = IRM, IRP - K = K + 1 - F1 = Q(KR,JN-1) - F2 = Q(KR,JN) - F3 = Q(KR,JN+1) - F4 = Q(KR,JN+2) - QK(K) = COMPUTE2(F1,F2,F3,F4,DN) - ENDDO - F1 = QK(1) - F2 = QK(2) - F3 = QK(3) - F4 = QK(4) - QQ = COMPUTE2(F1,F2,F3,F4,DR) - END SUBROUTINE SPLN44 - - SUBROUTINE SPLNI4(Q,NI,NJ,IR,JN,DN,QQ) - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NI, NJ, IR, JN - REAL*8, INTENT(IN) :: Q(NI,NJ), DN - REAL*8, INTENT(OUT) :: QQ - -!nu REAL*8,save :: CUSPWM=1., CUSPWE=1. ,CUSPWT,fflinr - REAL*8 f1, f2, f3, f4 - REAL*8, EXTERNAL :: COMPUTE2 - - F1 = Q(IR,JN-1) - F2 = Q(IR,JN) - F3 = Q(IR,JN+1) - F4 = Q(IR,JN+2) - QQ = COMPUTE2(F1,F2,F3,F4,DN) - END SUBROUTINE SPLNI4 - - ! input parameters - ! SW input ( 6,110) - ! LW input (33,110) - ! SETREL output - ! RQ input (110) - ! 3(6,190),(33,190) - SUBROUTINE SETREL(REFF0,NAER,KDREAD,SRUQEX,SRUQSC,SRUQCB,TRUQEX, & - TRUQSC,TRUQCB,REFU22,Q55U22,FRSULF,SRHQEX, & - SRHQSC,SRHQCB,TRHQAB,RHDATA) - ! RH info (190,9) - - USE FILEMANAGER, ONLY:OPENUNIT, CLOSEUNIT - USE DOMAIN_DECOMP_ATM, ONLY:AM_I_ROOT - IMPLICIT NONE - - INTEGER NAER, KDREAD - REAL*8 REFF0, SRUQEX(6,110), SRUQSC(6,110), SRUQCB(6,110), & - TRUQEX(33,110), TRUQSC(33,110), TRUQCB(33,110), REFU22(110)& - , Q55U22(110), FRSULF(8) - REAL*8 SRHQEX(6,190), SRHQSC(6,190), SRHQCB(6,190), TRHQAB(33,190)& - , RHDATA(190,15) - -! ------------------------------------------------------------------ -! REFF0 = Effective radius for dry aerosol seed size (in microns) -! NAER = Aerosol composition index -! KDREAD = IO READ unit number for Q(m,r),g(m,r) data used by SETREL -! ------------------------------------------------------------------ -! Aerosol index = NAER Composition Input data order = NNA -! 1 SO4 Sulfate 1 -! 2 SEA Sea Salt 2 -! 3 NO3 Nitrate 3 -! Pure Water 4 -! 4 ORG Organic 5 -! ------------------------------------------------------------------ - - CHARACTER*40, SAVE :: dtfile = & - &'oct2003.relhum.nr.Q633G633.table' - LOGICAL qexist - INTEGER i, j, j1, k, k1, in1, ir1, jdry, jwet, jhimax, khimax, & - maxdry, maxwet - INTEGER n, n0, n1, nn, np, nrhn1 - REAL*8 x, xx, xi, xn0, xn1, xr1, ff, fi, gi, gd1, gd2, gw1, gw2, & - grh, qrh, rrh - REAL*8 rh, rhi, rr0, rd1, rd2, rw1, rw2, dwr, qd1, qd2, qw1, qw2, & - xdry, sdry - REAL*8 xwet, swet, qqdmax, qqwmax, rqdmax, rqwmax, q55dry, q63dry,& - dwn - REAL*8 aermas, ddry, dwet, reffi, rhrhi, sum, sumw, vd1, vd2, vw1,& - vw2 - REAL*8 w1, w2, w3, w4, wd1, wd2, ww1, ww2, wtx, wty, wtz, wts, & - wta, xfdry - REAL*8 q55rh1, q55rh2, q55rh3, q55rh4, q550, q633, qgaerx, qscqcb - -! Output variables (RHDATA/RHINFO) - - REAL*8 RHRHRH(190), RHTAUF(190), RHREFF(190), RHWGM2(190), & - RHDGM2(190), RHTGM2(190), RHXMFX(190), RHDENS(190), & - RHQ550(190), TAUM2G(190), XNRRHX(190), ANBCM2(190), & - COSBAR(190), PIZERO(190), ANGSTR(190), RHINFO(190,15) - - EQUIVALENCE (RHINFO(1,1),RHRHRH(1)) - EQUIVALENCE (RHINFO(1,2),RHTAUF(1)) - EQUIVALENCE (RHINFO(1,3),RHREFF(1)) - EQUIVALENCE (RHINFO(1,4),RHWGM2(1)) - EQUIVALENCE (RHINFO(1,5),RHDGM2(1)) - EQUIVALENCE (RHINFO(1,6),RHTGM2(1)) - EQUIVALENCE (RHINFO(1,7),RHXMFX(1)) - EQUIVALENCE (RHINFO(1,8),RHDENS(1)) - EQUIVALENCE (RHINFO(1,9),RHQ550(1)) - EQUIVALENCE (RHINFO(1,10),TAUM2G(1)) - EQUIVALENCE (RHINFO(1,11),XNRRHX(1)) - EQUIVALENCE (RHINFO(1,12),ANBCM2(1)) - EQUIVALENCE (RHINFO(1,13),COSBAR(1)) - EQUIVALENCE (RHINFO(1,14),PIZERO(1)) - EQUIVALENCE (RHINFO(1,15),ANGSTR(1)) - -! ------------------------------------------------------------------ -! RHDATA/ Local -! RHINFO Variable Description -! ------ -------- ---------------------------------------------- -! 1 RHRHRH Relative humidity index RH (DO 110 0.0-0.999) -! 2 RHTAUF Dry TAU multiplication factor due to RH effect -! 3 RHREFF RH dependent effective radius -! 4 RHWGM2 Liquid water content (g/m2) per unit (dry) TAU -! 5 RHDGM2 Dry mass density (g/m2) per unit (dry) TAU -! 6 RHTGM2 Total mass density (g/m2) per unit (dry) TAU -! 7 RHXMFX Dry mass fraction X of total aerosol mass -! 8 RHDENS RH dependent density (g/cm3) -! 9 RHQ550 RH dependent Mie extinction efficiency (550nm) -! 10 TAUM2G RH dependent TAU factor (m2/g) of dry aerosol -! 11 XNRRHX RH dependent real refractive index -! 12 ANBCM2 Aerosol Number density (Billion)/cm2 -! 13 COSBAR RH dependent Mie asymmetry parameter (visible) -! 14 PIZERO RH dependent single scattering albedo(visible) -! 15 ANGSTR Angstrom exponent = -(1-SRHQEX(5)/(0.55-0.815) -! ------------------------------------------------------------------ - - -! Local variables - - REAL*8 R633NR(890), XNR(31), Q633NR(890,31), G633NR(890,31) - REAL*8 Q880M1(890), G880M1(890), Q880M0(890), G880M0(890) - REAL*8 Q880N1(890), Q880N0(890), R550NR(890), SMOOTH(890) - REAL*8 RR0RHX(190), QRH633(190), GRH633(190), DNRX(190) - - - REAL*8 QXAERN(33), QSAERN(33), QGAERN(33), SR1QEX(6), SR1QSC(6), & - SR1QCB(6), SR2QEX(6), SR2QSC(6), SR2QCB(6), SR3QEX(6), & - SR3QSC(6), SR3QCB(6), SR4QEX(6), SR4QSC(6), SR4QCB(6), & - TR1QEX(33), TR1QSC(33), TR1QCB(33), TR2QEX(33), TR2QSC(33),& - TR2QCB(33), TR3QEX(33), TR3QSC(33), TR3QCB(33), TR4QEX(33),& - TR4QSC(33), TR4QCB(33), TRHQEX(33), TRHQSC(33), TRHQCB(33) - - INTEGER, PARAMETER, DIMENSION(4) :: NRHCRY = (/38,47,28,38/) - - CHARACTER*8 AERTYP(4) - DATA AERTYP/'Sulfate ', 'SeaSalt ', 'Nitrate ', 'Organic '/ - -! ------------------------------------------------------------------ -! Hygroscopic aerosols (Sulfate,SeaSalt,Nitrate) physical properties -! formulas from Tang and Munkelwitz (1994, 1996) in JGR 99, JGR 101. -! -! AW=water activity RO=density BX=growth factor RX=refractive index -! SO4 = ammonium sulfate; SEA = sea salt; NO3 = ammonium nitrate -! ------------------------------------------------------------------ - -! functions - - REAL*8 AWSO4, DWSO4, ROSO4, BXSO4, RXSO4, DRWSO4, DRDSO4 - REAL*8 AWSEA, DWSEA, ROSEA, BXSEA, RXSEA, DRWSEA, DRDSEA - REAL*8 RRSEA, VVSEA, GXSEA - REAL*8 AWNO3, DWNO3, RONO3, BXNO3, R1NO3, R2NO3, DRXNO3 - REAL*8 AWOCX, DWOCX, ROOCX, BXOCX, RXOCX, DRWOCX, DRDOCX - - ! Sulfate parametric formulas from Tang Munkelwitz(94,96) - AWSO4(X) = 1.D0 - 0.2715*X + 0.3113*X**2 - 2.336*X**3 + 1.412*X**4 - ! TM94 - DWSO4(X) = -0.2715D0 + 0.6226*X - 7.008*X**2 + 5.648*X**3 - ROSO4(X) = 0.9971D0 + 5.92D-01*X - 5.036D-02*X**2 + 1.024D-02*X**3 - ! TM94 - BXSO4(X) = (1.D0/X*1.760D0/ROSO4(X))**(1.D0/3.D0) ! TM96 - RXSO4(X) = 1.3330 + 0.16730*X - 0.0395*X**2 ! TM91 - DRWSO4(RH) = 1.002146 - 0.00149*RH + 0.001*RH/(1.0+0.911*RH**10) - DRDSO4(RH) = 1.002503 ! ratio of wet dry nr(0.550) / nr(0.633) - - ! SeaSalt parametric formulas from Tang Munkelwitz(94,96) - AWSEA(X) = 1.0D0 - 0.6366*X + 0.8624*X**2 - 11.58*X**3 + & - 15.18*X**4 ! TM96 - DWSEA(X) = -0.6366D0 + 1.7248*X - 34.74*X**2 + 60.72*X**3 - ROSEA(X) = 0.9971 + 0.741*X - 0.3741*X**2 + 2.252*X**3 - & - 2.060*X**4 ! TM96 - BXSEA(X) = (1.D0/X*2.165D0/ROSEA(X))**(1.D0/3.D0) - RRSEA(X) = 3.70958 + (8.95-3.70958)/(1.D0+(1.0-X)/X*58.448/18.0) - VVSEA(X) = (18.0+(58.448-18.0)/(1.0+(1.0-X)/X*58.448/18.0)) & - /ROSEA(X) - GXSEA(X) = SQRT((2.D0*RRSEA(X)+VVSEA(X))/(VVSEA(X)-RRSEA(X))) - ! TM96 - RXSEA(X) = 1.333 + (GXSEA(X)-1.333)*(1.490-1.333)/(1.544-1.333) - DRWSEA(RH) = 1.00212 - 0.001625*RH + 0.00131*RH/(1.0+0.928*RH**3) - DRDSEA(RH) = 1.003007 ! ratio of wet dry nr(0.550) / nr(0.633) - - ! Nitrate parametric formulas from Tang Munkelwitz(94,96) - AWNO3(X) = 1.D0 - 3.65D-01*X - 9.155D-02*X**2 - 2.826D-01*X**3 - ! TM96 - DWNO3(X) = -3.65D-01 - 18.31D-02*X - 8.478D-01*X**3 - RONO3(X) = 0.9971D0 + 4.05D-01*X + 9.0D-02*X**2 ! TM96 - BXNO3(X) = (1.D0/X*1.725D0/RONO3(X))**(1.D0/3.D0) ! TM96 - R1NO3(X) = 1.3330 + 0.119D0*X ! (X<0.205) TWM81 - R2NO3(X) = 1.3285 + 0.145D0*X ! (X>0.205) TWM81 - DRXNO3(RH) = 1.001179 ! ratio of wet dry nr(0.550) / nr(0.633) - - ! Organic Carbon - adapted from Sulfate parametric formulas - ! yields growth factor G=1.1 at RH=0.84 Virkkula et al 1999 - AWOCX(X) = 1D0 - X**8D0 - DWOCX(X) = -8D0*X**7D0 - ROOCX(X) = 1D0 + .5D0*X - BXOCX(X) = (1.5D0/(X*ROOCX(X)))**(1D0/3D0) - RXOCX(X) = 1.3330D0 + .193D0*X - DRWOCX(RH) = 1.00253 - 0.00198*RH + 0.00184*RH/(1.0+0.656*RH**1.1) - DRDOCX(RH) = 1.00253 - -! ------------------------------------------------------------------ -! Q,G Mie data (879x31) at 0.633 microns, use 31 points to cover the -! refractive index from 1.30 to 1.60 with equal spacing of 0.01 -! -! Q,G data effective radius spans the range from 0.0 to 20.4 microns -! in (3) segments of equally spaced data for optimized 4-point Cubic -! Spline interpolation. The equally spaced segments are as follows: -! -! Index: 1 - 303 304 - 603 604 - 879 881 - 885 886 - 890 -! Reff: 0.00-3.02 3.04-9.02 9.04-20.04 2.98-3.04 8.96-9.08 -! Delta: 0.01 0.02 0.04 0.02 0.04 -! -! The last two intervals are constructed to accommodate transitions -! between the (3) segments using 4-point Cubic Spline interpolation -! ------------------------------------------------------------------ - - - INQUIRE (FILE=dtfile,EXIST=qexist) - IF ( .NOT.qexist ) dtfile = 'RH_QG_Mie ' - ! generic name used by GCM - INQUIRE (FILE=dtfile,EXIST=qexist) - IF ( .NOT.qexist ) CALL STOP_MODEL('setrel: no RH_QG files',255) - CALL OPENUNIT(dtfile,kdread,.FALSE.,.TRUE.) ! formatted, old - - READ (KDREAD,7000) (XNR(J),J=1,31) - DO I = 1, 880 - READ (KDREAD,7001) R633NR(I), (Q633NR(I,J),J=1,31) - ENDDO - READ (KDREAD,7000) (XNR(J),J=1,31) - DO I = 1, 880 - READ (KDREAD,7001) R633NR(I), (G633NR(I,J),J=1,31) - ENDDO - CALL CLOSEUNIT(KDREAD) - - J = 880 - DO K = 299, 305 - IF ( K/=300 ) THEN - IF ( K/=302 ) THEN - J = J + 1 - R633NR(J) = R633NR(K) - DO I = 1, 31 - Q633NR(J,I) = Q633NR(K,I) - G633NR(J,I) = G633NR(K,I) - ENDDO - ENDIF - ENDIF - ENDDO - DO K = 600, 606 - IF ( K/=601 ) THEN - IF ( K/=603 ) THEN - J = J + 1 - R633NR(J) = R633NR(K) - DO I = 1, 31 - Q633NR(J,I) = Q633NR(K,I) - G633NR(J,I) = G633NR(K,I) - ENDDO - ENDIF - ENDIF - ENDDO - -! Apply 13-point quadratic least-squares smoothing to large particle -! portion of Mie Qx data to eliminate low-amplitude ripple in Q633NR -! (Monotonic size dependence is needed for inverse Qx interpolation) -! (Smoothing affects 4th decimal of Q633NR for large particle sizes) -! ------------------------------------------------------------------ - DO I = 1, 31 - DO J = 1, 880 - SMOOTH(J) = Q633NR(J,I) - ENDDO - DO J = 881, 886 - SMOOTH(J) = SMOOTH(880) - ENDDO - DO J = 250, 880 - J1 = J - 2 - IF ( SMOOTH(J)>=SMOOTH(J-1) ) EXIT - ENDDO - DO J = J1, 880 - SUM = 4550.D0/13.D0*SMOOTH(J) - DO K = 1, 6 - SUM = SUM + (4550.D0/13.D0-14*K*K) & - *(SMOOTH(J-K)+SMOOTH(J+K)) - ENDDO - Q633NR(J,I) = SUM/2002.D0 - ENDDO - ENDDO - -! Set relative humidity RHRHRH scale -! ---------------------------------- - DO I = 1, 190 - RHRHRH(I) = (I-1)/100.D0 - IF ( I>91 ) RHRHRH(I) = 0.90D0 + (I-91)/1000.D0 - ENDDO - -! Define RH (=AW), RO, BX, RX as functions of X for NAER aerosol -! -------------------------------------------------------------- - NRHN1 = NRHCRY(NAER) + 1 - DO I = 1, 190 - RHI = RHRHRH(I) - RR0RHX(I) = 1.D0 - RHXMFX(I) = 1.D0 - IF ( NAER==1 ) THEN ! Dry Sulfate refrac index and density - XNRRHX(I) = 1.526 - RHDENS(I) = 1.760 - IF ( I=NRHN1 ) DNRX(I) = DRWSO4(RHI) - ENDIF - IF ( NAER==2 ) THEN ! Dry SeaSalt refrac index and density - XNRRHX(I) = 1.490 - RHDENS(I) = 2.165 - IF ( I=NRHN1 ) DNRX(I) = DRWSEA(RHI) - ENDIF - IF ( NAER==3 ) THEN ! Dry Nitrate refrac index and density - XNRRHX(I) = 1.554 - RHDENS(I) = 1.725 - DNRX(I) = DRXNO3(RHRHRH(I)) - ENDIF - IF ( NAER==4 ) THEN ! Dry Organic refrac index and density - XNRRHX(I) = 1.526 ! (representative value) - RHDENS(I) = 1.5 ! (representative value) - IF ( I=NRHN1 ) DNRX(I) = DRWOCX(RHI) - ENDIF - ENDDO - -! Invert X, RO, BX, RX functions of (X) to be functions of RH -! ----------------------------------------------------------- - I = 191 - FF = 1.D0 - XX = 0.D0 - IF ( NAER==1 ) GI = DWSO4(XX) - IF ( NAER==2 ) GI = DWSEA(XX) - IF ( NAER==3 ) GI = DWNO3(XX) - IF ( NAER==4 ) THEN - FF = .9995D0 - XX = (1D0-FF)**.125D0 - GI = DWOCX(XX) - ENDIF - DO - I = I - 1 - FI = RHRHRH(I) - DO K = 1, 5 - XI = XX - (FF-FI)/GI - IF ( NAER==1 ) FF = AWSO4(XI) - IF ( NAER==2 ) FF = AWSEA(XI) - IF ( NAER==3 ) FF = AWNO3(XI) - IF ( NAER==4 ) FF = AWOCX(XI) - IF ( I>0 ) THEN - ENDIF - XX = XI - IF ( NAER==1 ) GI = DWSO4(XX) - IF ( NAER==2 ) GI = DWSEA(XX) - IF ( NAER==3 ) GI = DWNO3(XX) - IF ( NAER==4 ) GI = DWOCX(XX) - ENDDO - RHXMFX(I) = XX - IF ( NAER==1 ) THEN ! RH dependent Sulfate X,R,NR,RO - RHDENS(I) = ROSO4(XX) - RR0RHX(I) = BXSO4(XX) - XNRRHX(I) = RXSO4(XX) - ENDIF - IF ( NAER==2 ) THEN ! RH dependent SeaSalt X,R,NR,RO - RHDENS(I) = ROSEA(XX) - RR0RHX(I) = BXSEA(XX) - XNRRHX(I) = RXSEA(XX) - ENDIF - IF ( NAER==3 ) THEN ! RH dependent Nitrate X,R,NR,RO - RHDENS(I) = RONO3(XX) - RR0RHX(I) = BXNO3(XX) - XNRRHX(I) = R1NO3(XX) - IF ( XX>0.205D0 ) XNRRHX(I) = R2NO3(XX) - ENDIF - IF ( NAER==4 ) THEN ! RH dependent Organic X,R,NR,RO - RHDENS(I) = ROOCX(XX) - RR0RHX(I) = BXOCX(XX) - XNRRHX(I) = RXOCX(XX) - ENDIF - IF ( I<=NRHN1 ) THEN - -! ------------------------------------------------------------------ -! Find Qdry(r),gdry(r) from Q(m,r),g(m,r) maps for each aerosol type -! Find Qwet(r),gwet(r) from Q(m,r),g(m,r) maps for each aerosol type -! also locate MAXDRY,MAXWET pts where Qdry(r),Qwet(r) are at maximum -! (M1 refers to mass fraction X of 1.0, i.e., "dry" aerosol) -! (M0 refers to mass fraction X of 0.0, i.e., "wet" aerosol) -! ------------------------------------------------------------------ - MAXDRY = 1 - MAXWET = 1 - QQDMAX = 0.D0 - QQWMAX = 0.D0 - XDRY = XNRRHX(1) -! IF(MCRYON == 1) XDRY=XNRRHX(NRHN1) ! If "dry" = RHC reference line - SDRY = XDRY*100.D0 - 129 - JDRY = SDRY - DDRY = SDRY - JDRY - XWET = 1.3330D0 ! Pure water Nr = "wet" aerosol - SWET = XWET*100.D0 - 129 - JWET = SWET - DWET = SWET - JWET - DO I = 1, 880 - CALL SPLNI4(Q633NR,890,31,I,JDRY,DDRY,Q880M1(I)) - CALL SPLNI4(G633NR,890,31,I,JDRY,DDRY,G880M1(I)) - CALL SPLNI4(Q633NR,890,31,I,JWET,DWET,Q880M0(I)) - CALL SPLNI4(G633NR,890,31,I,JWET,DWET,G880M0(I)) - IF ( Q880M1(I)>QQDMAX ) THEN - QQDMAX = Q880M1(I) - MAXDRY = I - ENDIF - IF ( Q880M0(I)>QQWMAX ) THEN - QQWMAX = Q880M0(I) - MAXWET = I - ENDIF - ENDDO - RQDMAX = R633NR(MAXDRY) - RQWMAX = R633NR(MAXWET) - -! Define: Qdry(r) and Qwet(r) at the reference wavelength of 550 nm -! using refractive index off-set and size parameter scaling -! ------------------------------------------------------------------ - XDRY = XNRRHX(1)*DNRX(1) ! Dry aerosol Nr at 550 nm -! IF(MCRYON == 1) XDRY=XNRRHX(NRHN1) ! If "dry" = RHC reference line - SDRY = XDRY*100.D0 - 129 - JDRY = SDRY - DDRY = SDRY - JDRY - XWET = 1.3330D0*1.001179 - ! Pure water aerosol Nr at 550 nm - SWET = XWET*100.D0 - 129 - JWET = SWET - DWET = SWET - JWET - DO I = 1, 880 - CALL SPLNI4(Q633NR,890,31,I,JDRY,DDRY,Q880N1(I)) - CALL SPLNI4(Q633NR,890,31,I,JWET,DWET,Q880N0(I)) - R550NR(I) = R633NR(I)*(0.550/0.633) - ! Size shift refers Q to 550 nm - ENDDO - CALL SPLINE(R550NR,Q880N1,880,REFF0,Q55DRY,1.D0,1.D0,1) - CALL SPLINE(R633NR,Q880M1,880,REFF0,Q63DRY,1.D0,1.D0,1) - -! Find Q(RH),g(RH) paths in Q(m,r),g(m,r) maps for seed size = REFF0 -! 2-coordinate paths defined via XN0=XNRRHX(I) RR0=REFF0*RR0RHX(I) -! ------------------------------------------------------------------ - DO I = 1, 190 - XN0 = XNRRHX(I) - XN1 = XN0*100.D0 - 129 - IN1 = XN1 - DWN = XN1 - IN1 - RR0 = REFF0*RR0RHX(I) - IF ( RR0<0.01 ) RR0 = 0.01 - IF ( RR0<=3.00D0 ) XR1 = RR0*100.D0 + 1 - IF ( RR0>3.00D0 .AND. RR0<3.04D0 ) XR1 = RR0*50.0D0 + 732 - IF ( RR0>=3.04D0 .AND. RR0<=9.00D0 ) XR1 = RR0*50.0D0 + & - 152 - IF ( RR0>9.00D0 .AND. RR0<9.08D0 ) XR1 = RR0*25.0D0 + 662 - IF ( RR0>=9.08D0 ) THEN - XR1 = RR0*25.0D0 + 378 - IF ( XR1>877.9999D0 ) XR1 = 877.9999D0 - ENDIF - IR1 = XR1 - DWR = XR1 - IR1 - CALL SPLN44(Q633NR,890,31,IR1,DWR,IN1,DWN,QRH633(I)) - CALL SPLN44(G633NR,890,31,IR1,DWR,IN1,DWN,GRH633(I)) - ENDDO - -! Define Q55(RH) by tracing path in Q(m,r) map for RH dependent size -! via 2-coordinate path XN0=XNRRHX(I)*DNRX(I), RR0=RRH(I)*(.633/.55) -! ------------------------------------------------------------------ - DO I = 1, 190 - XN0 = XNRRHX(I)*DNRX(I) - XN1 = XN0*100.D0 - 129 - IN1 = XN1 - DWN = XN1 - IN1 - RR0 = REFF0*RR0RHX(I)*(0.633D0/0.550D0) - IF ( RR0<0.01 ) RR0 = 0.01 - IF ( RR0<=3.00D0 ) XR1 = RR0*100.D0 + 1 - IF ( RR0>3.00D0 .AND. RR0<3.04D0 ) XR1 = RR0*50.0D0 + 732 - IF ( RR0>=3.04D0 .AND. RR0<=9.00D0 ) XR1 = RR0*50.0D0 + & - 152 - IF ( RR0>9.00D0 .AND. RR0<9.08D0 ) XR1 = RR0*25.0D0 + 662 - IF ( RR0>=9.08D0 ) THEN - XR1 = RR0*25.0D0 + 378 - IF ( XR1>877.9999D0 ) XR1 = 877.9999D0 - ENDIF - IR1 = XR1 - DWR = XR1 - IR1 - CALL SPLN44(Q633NR,890,31,IR1,DWR,IN1,DWN,RHQ550(I)) - RHREFF(I) = RR0RHX(I)*REFF0 - ENDDO - -! Aerosol liquid water content is in kg/m2 per unit optical depth -! of dry aerosol with aerosol effective radius expressed in microns. -! ------------------------------------------------------------------ - - DO I = 1, 190 - RHTAUF(I) = (RHQ550(I)/Q55DRY)*RR0RHX(I)**2 - AERMAS = 1.33333333D0*RHREFF(I)*RHDENS(I)/RHQ550(I) & - *RHTAUF(I) - RHTGM2(I) = AERMAS - RHDGM2(I) = AERMAS*RHXMFX(I) - RHWGM2(I) = RHTGM2(I) - RHDGM2(I) - TAUM2G(I) = 0.75D0/RHDENS(1)/RHREFF(1)*RHQ550(1) & - *RHTAUF(I) - ANBCM2(I) = TAUM2G(I)/(1.5080*RHQ550(I)*RHREFF(I)**2) - ENDDO - -! Determination of RH dependent Mie scattering tables for GCM input. -! Find equivalent aersol dry sizes (RD1,RD2) and wet sizes (RW1,RW2) -! and corresponding weights to match the RH dependent Q(r) and g(r). -! Fits made to form: QRH=X*[Y*QD1+(1-Y)*QD2]+(1-X)*[Z*WD1+(1-Z)*WD2] -! ------------------------------------------------------------------ - J1 = MAXWET - JHIMAX = 881 - MAXWET - K1 = MAXDRY - KHIMAX = 881 - MAXDRY - NP = 190 - NRHN1 + 1 - DO I = 1, 190 - RHRHI = RHRHRH(I) - XFDRY = RHXMFX(I) - REFFI = RHREFF(I) - RRH = RR0RHX(I)*REFF0 - GRH = GRH633(I) - QRH = QRH633(I) - QD1 = QRH - QD2 = QRH - QW1 = QRH - QW2 = QRH - IF ( QW1>QQWMAX ) QW1 = QQWMAX - IF ( QW2>QQWMAX ) QW2 = QQWMAX - CALL SPLINV(R633NR,Q880M0,MAXWET,RW1,QW1,1.D0,1.D0,1) - CALL SPLINV(R633NR(J1),Q880M0(J1),JHIMAX,RW2,QW2,1.D0, & - 1.D0,1) - CALL SPLINE(R633NR,G880M0,880,RW1,GW1,1.D0,1.D0,1) - CALL SPLINE(R633NR,G880M0,880,RW2,GW2,1.D0,1.D0,1) - IF ( I>=NRHN1 .AND. QRH>QQWMAX ) THEN - QD1 = QQWMAX + (QRH-QQWMAX)/XFDRY - ! QD1 such that QRH=X*QD1+(1-X)*QW1 - QD2 = 2.3D0 ! 2 dry sizes are used if QD1>QQWMAX - ENDIF - CALL SPLINV(R633NR,Q880M1,MAXDRY,RD1,QD1,1.D0,1.D0,1) - CALL SPLINV(R633NR(K1),Q880M1(K1),KHIMAX,RD2,QD2,1.D0, & - 1.D0,1) - CALL SPLINE(R633NR,G880M1,880,RD1,GD1,1.D0,1.D0,1) - CALL SPLINE(R633NR,G880M1,880,RD2,GD2,1.D0,1.D0,1) - - IF ( IRQDMAX ) WTY = 0.D0 - WTZ = 1.D0 - ELSE ! Dry/wet weighted average regions (2)-(4) - IF ( QRH<=QQWMAX .AND. REFFIQQWMAX ) THEN ! Medium-size region (3) -! Fit form: QRH=X*(Y*QD1+(1-Y)*QD2)+(1-X)*QWmax QRH=/QD1=/QD2=/QW1 - WTZ = 1.D0 - WTY = ((GRH-GD2)*QRH*QD2+(GD2-GW1) & - *QD2*QW1+(GW1-GRH)*QRH*QW1) & - /((GD1-GRH)*QRH*QD1+(GRH-GD2) & - *QRH*QD2+(GW1-GD1)*QD1*QW1+(GD2-GW1)*QD2*QW1) - WTX = (QRH-QW1)/(WTY*(QD1-QD2)+(QD2-QW1)) - ENDIF - IF ( QRH<=QQWMAX .AND. REFFI>RW1 ) THEN - ! Large size region (4) - WTY = 0.D0 - WTZ = 0.D0 - WTX = (GRH-GW2)/(GD2-GW2) - ENDIF - ENDIF - IF ( REFFI>RQWMAX .AND. RHRHI>0.995 ) THEN - ! High RH region (5) - WTY = 0.D0 - WTX = XFDRY - WTZ = ((GRH-GW2)-(GD2-GW2)*WTX)/((1.D0-WTX)*(GW1-GW2)) - ENDIF - - VD1 = WTX*WTY - VD2 = WTX*(1.D0-WTY) - VW1 = WTZ*(1.D0-WTX) - VW2 = (1.D0-WTZ)*(1.D0-WTX) - RD1 = MIN(RD1,10.D0) - RD2 = MIN(RD2,10.D0) - RW1 = MIN(RW1,10.D0) - RW2 = MIN(RW2,10.D0) - -! Computed weight factors are for Lab reference wavelength of 633nm. -! Rescale spectral extinction to 550 nm renormalize weight factors -! ------------------------------------------------------------------ - CALL SPLINE(R550NR,Q880N1,880,RD1,Q550,1.D0,1.D0,1) - CALL SPLINE(R633NR,Q880M1,880,RD1,Q633,1.D0,1.D0,1) - WD1 = VD1*(Q550/Q633) - CALL SPLINE(R550NR,Q880N1,880,RD2,Q550,1.D0,1.D0,1) - CALL SPLINE(R633NR,Q880M1,880,RD2,Q633,1.D0,1.D0,1) - WD2 = VD2*(Q550/Q633) - CALL SPLINE(R550NR,Q880N0,880,RW1,Q550,1.D0,1.D0,1) - CALL SPLINE(R633NR,Q880M0,880,RW1,Q633,1.D0,1.D0,1) - WW1 = VW1*(Q550/Q633) - CALL SPLINE(R550NR,Q880N0,880,RW2,Q550,1.D0,1.D0,1) - CALL SPLINE(R633NR,Q880M0,880,RW2,Q633,1.D0,1.D0,1) - WW2 = VW2*(Q550/Q633) - SUMW = WD1 + WD2 + WW1 + WW2 - W1 = WD1/SUMW - W2 = WD2/SUMW - W3 = WW1/SUMW - W4 = WW2/SUMW - -! ------------------------------------------------------------------ -! Tabulate relative humidity dependent solar, thermal Mie scattering -! parameters SRHQEX,SRHQSC,SRHQCS, TRHQAB for each aerosol type NAER -! These are mass weighted averages of equivalent dry and wet aerosol -! parameters for sizes matching the relative humidity dependent Q(r) -! ------------------------------------------------------------------ - - N0 = 0 ! Select Mie parameters for Sulfate - IF ( NAER==2 ) N0 = 22 - ! Select Mie parameters for SeaSalt - IF ( NAER==3 ) N0 = 44 - ! Select Mie parameters for Nitrate - IF ( NAER==4 ) N0 = 88 - ! Select Mie parameters for Organic - N1 = N0 + 1 - DO K = 1, 6 ! SW dry sizes RD1 RD2 - DO N = 1, 22 - NN = N0 + N - WTS = FRSULF(NAER) - WTA = 1.D0 - WTS - QXAERN(N) = SRUQEX(K,NN)*WTA + SRUQEX(K,N)*WTS - QSAERN(N) = SRUQSC(K,NN)*WTA + SRUQSC(K,N)*WTS - QGAERX = SRUQCB(K,NN)*SRUQSC(K,NN) & - *WTA + SRUQCB(K,N)*SRUQSC(K,N)*WTS - QGAERN(N) = QGAERX/QSAERN(N) - ENDDO - CALL SPLINE(REFU22,QXAERN,22,RD1,SR1QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RD1,SR1QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RD1,SR1QCB(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QXAERN,22,RD2,SR2QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RD2,SR2QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RD2,SR2QCB(K),1.D0,1.D0, & - 1) - ENDDO - - DO K = 1, 33 ! LW dry sizes RD1 RD2 - DO N = 1, 22 - NN = N0 + N - WTS = FRSULF(NAER) - WTA = 1.D0 - WTS - QXAERN(N) = TRUQEX(K,NN)*WTA + TRUQEX(K,N)*WTS - QSAERN(N) = TRUQSC(K,NN)*WTA + TRUQSC(K,N)*WTS - QGAERX = TRUQCB(K,NN)*TRUQSC(K,NN) & - *WTA + TRUQCB(K,N)*TRUQSC(K,N)*WTS - QGAERN(N) = QGAERX/(QSAERN(N)+1D-10) - ENDDO - CALL SPLINE(REFU22,QXAERN,22,RD1,TR1QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RD1,TR1QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RD1,TR1QCB(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QXAERN,22,RD2,TR2QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RD2,TR2QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RD2,TR2QCB(K),1.D0,1.D0, & - 1) - ENDDO - CALL SPLINE(REFU22,Q55U22(N1),22,RD1,Q55RH1,1.D0,1.D0,1) - CALL SPLINE(REFU22,Q55U22(N1),22,RD2,Q55RH2,1.D0,1.D0,1) - - N0 = 66 ! Select Mie parameters for pure water - N1 = N0 + 1 - DO K = 1, 6 ! SW wet sizes RW1 RW2 - DO N = 1, 22 - NN = N0 + N - QXAERN(N) = SRUQEX(K,NN) - QSAERN(N) = SRUQSC(K,NN) - QGAERN(N) = SRUQCB(K,NN) - ENDDO - CALL SPLINE(REFU22,QXAERN,22,RW1,SR3QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RW1,SR3QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RW1,SR3QCB(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QXAERN,22,RW2,SR4QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RW2,SR4QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RW2,SR4QCB(K),1.D0,1.D0, & - 1) - ENDDO - - DO K = 1, 33 ! LW wet sizes RW1 RW2 - DO N = 1, 22 - NN = N0 + N - QXAERN(N) = TRUQEX(K,NN) - QSAERN(N) = TRUQSC(K,NN) - QGAERN(N) = TRUQCB(K,NN) - ENDDO - CALL SPLINE(REFU22,QXAERN,22,RW1,TR3QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RW1,TR3QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RW1,TR3QCB(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QXAERN,22,RW2,TR4QEX(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QSAERN,22,RW2,TR4QSC(K),1.D0,1.D0, & - 1) - CALL SPLINE(REFU22,QGAERN,22,RW2,TR4QCB(K),1.D0,1.D0, & - 1) - ENDDO - CALL SPLINE(REFU22,Q55U22(N1),22,RW1,Q55RH3,1.D0,1.D0,1) - CALL SPLINE(REFU22,Q55U22(N1),22,RW2,Q55RH4,1.D0,1.D0,1) - - ! Weighted GCM SW Mie scattering parameters - DO K = 1, 6 - SRHQEX(K,I) = W1*SR1QEX(K) + W2*SR2QEX(K) & - + W3*SR3QEX(K) + W4*SR4QEX(K) - SRHQSC(K,I) = W1*SR1QSC(K) + W2*SR2QSC(K) & - + W3*SR3QSC(K) + W4*SR4QSC(K) - QSCQCB = W1*SR1QCB(K)*SR1QSC(K) + W2*SR2QCB(K) & - *SR2QSC(K) + W3*SR3QCB(K)*SR3QSC(K) & - + W4*SR4QCB(K)*SR4QSC(K) - SRHQCB(K,I) = QSCQCB/SRHQSC(K,I) - ENDDO - ! Weighted GCM LW Mie scattering parameters - DO K = 1, 33 - TRHQEX(K) = W1*TR1QEX(K) + W2*TR2QEX(K) + W3*TR3QEX(K)& - + W4*TR4QEX(K) - TRHQSC(K) = W1*TR1QSC(K) + W2*TR2QSC(K) + W3*TR3QSC(K)& - + W4*TR4QSC(K) - QSCQCB = W1*TR1QCB(K)*TR1QSC(K) + W2*TR2QCB(K) & - *TR2QSC(K) + W3*TR3QCB(K)*TR3QSC(K) & - + W4*TR4QCB(K)*TR4QSC(K) - TRHQCB(K) = QSCQCB/TRHQSC(K) - TRHQAB(K,I) = TRHQEX(K) - TRHQSC(K) - ENDDO - - COSBAR(I) = SRHQCB(6,I) - PIZERO(I) = SRHQSC(6,I)/SRHQEX(6,I) - ANGSTR(I) = -(1.D0-SRHQEX(5,I))/(0.550D0-0.815D0) - -! Transfer EQUIVALENCEd SETREL output information to RHDATA - DO J = 1, 15 - RHDATA(I,J) = RHINFO(I,J) - ENDDO - ENDDO - -! Diagnostic output - IF ( AM_I_ROOT() ) THEN - DO I = 1, 190 - IF ( I==1 ) WRITE (99,6000) AERTYP(NAER), NAER, REFF0 - IF ( I==82 ) WRITE (99,6000) AERTYP(NAER), NAER, REFF0 - IF ( I==137 ) WRITE (99,6000) AERTYP(NAER), NAER, & - REFF0 - IF ( I>=27 ) THEN - WRITE (99,6100) I, (RHINFO(I,N),N=1,15), & - SRHQEX(6,I), SRHQEX(5,I), & - SRHQEX(1,I), TRHQAB(1,I) - 6100 FORMAT (I3,F5.3,18F8.4) - ENDIF - ENDDO - ENDIF - EXIT - ENDIF - ENDDO - 7000 FORMAT (12X,F5.3,30F8.3) - 7001 FORMAT (3X,F6.2,31F8.5) - 6000 FORMAT (T90,A8,' NAER=',I2,' REFF0=',F5.2// & - &' RH RHTAUF RHREFF RHWGM2 RHDGM2 RHTGM2 RHXMFX'& - , & - &' RHDENS RHQ550 TAUM2G XNRRHX ANBCM2 COSBAR PIZERO'& - ,' ANGSTR SRHQEX6 SRHQEX5 SRHQEX1 TRHQAB1') - - END SUBROUTINE SETREL - - REAL*8 FUNCTION RHDTNA(TK,NA) - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NA - REAL*8, INTENT(IN) :: TK -! functions - REAL*8 RHDSO4, RHDSEA, RHDNO3, RHDOCX - - RHDSO4(TK) = MIN(1.D0,0.80D0*EXP(25.D0*(298.0D0-TK)/(298.0D0*TK))) - RHDSEA(TK) = MIN(1.D0,0.75D0*EXP(80.D0*(298.0D0-TK)/(298.0D0*TK))) - RHDNO3(TK) = MIN(1.D0,0.62D0*EXP(852.D0*(298.0D0-TK)/(298.0D0*TK))& - ) - RHDOCX(TK) = MIN(1.D0,0.80D0*EXP(25.D0*(298.0D0-TK)/(298.0D0*TK))) - - IF ( NA==1 ) RHDTNA = RHDSO4(TK) - IF ( NA==2 ) RHDTNA = RHDSEA(TK) - IF ( NA==3 ) RHDTNA = RHDNO3(TK) - IF ( NA==4 ) RHDTNA = RHDOCX(TK) - END FUNCTION RHDTNA - - REAL*8 FUNCTION COMPUTE(f1,f2,f3,f4,var)RESULT(RESULT) - IMPLICIT NONE - REAL*8, INTENT(IN) :: f1, f2, f3, f4 - REAL*8, INTENT(IN) :: var - REAL*8 :: F21, F32, F43, F3221, F4332 - REAL*8 :: A, B, C, D, XF, FFCUSP, XEXM, CUSPWT - REAL*8 :: FFLINR - REAL*8, PARAMETER :: CUSPWM = 0.5 - REAL*8, PARAMETER :: CUSPWE = 0.5 - F21 = (F2-F1) - F32 = (F3-F2) - F43 = (F4-F3) - F3221 = (F32+F21)*0.5D0 - F4332 = (F43+F32)*0.5D0 - A = F2 - B = F3221 - C = 3.D0*F32 - F3221 - F3221 - F4332 - D = (F3221+F4332-F32-F32) - XF = var - FFCUSP = A + XF*(B+XF*(C+XF*D)) - XEXM = (1-2*XF)**2 ! = XE**2 - CUSPWT = (1.0-XEXM)*CUSPWM + XEXM*CUSPWE - FFLINR = A + XF*F32 - RESULT = FFCUSP*CUSPWT + FFLINR*(1.D0-CUSPWT) - END FUNCTION COMPUTE - - REAL*8 FUNCTION COMPUTE2(f1,f2,f3,f4,var)RESULT(RESULT) - IMPLICIT NONE - REAL*8, INTENT(IN) :: f1, f2, f3, f4 - REAL*8, INTENT(IN) :: var - REAL*8 :: F21, F32, F43, F3221, F4332 - REAL*8 :: A, B, C, D, XF, FFCUSP, XEXM, XE - F21 = (F2-F1) - F32 = (F3-F2) - F43 = (F4-F3) - F3221 = (F32+F21)*0.5D0 - F4332 = (F43+F32)*0.5D0 - A = F2 - B = F3221 - C = 3.D0*F32 - F3221 - F3221 - F4332 - D = (F3221+F4332-F32-F32) - XF = var - FFCUSP = A + XF*(B+XF*(C+XF*D)) - XE = 1.D0 - XF - XF - IF ( XE<0.0 ) XE = -XE - XEXM = XE**2 -!=1 CUSPWT=(1.D0-XEXM)*CUSPWM+XEXM*CUSPWE -!nu FFLINR=A+XF*F32 - RESULT = FFCUSP - END FUNCTION COMPUTE2 - - MODULE O3MOD -!@sum O3mod administers reading of ozone files -!@auth M. Kelley and original development team - USE TIMESTREAM_MOD, ONLY:TIMESTREAM - IMPLICIT NONE - SAVE -!@var O3stream interface for reading and time-interpolating O3 files -!@+ See usage notes in timestream_mod - TYPE (TIMESTREAM) :: O3stream, delta_O3stream -#ifdef HIGH_FREQUENCY_O3_INPUT - TYPE (TIMESTREAM) :: OxHFstream, PSFforO3stream -#endif -#ifdef GCAP - REAL*8, ALLOCATABLE :: save_to3(:,:) -#endif -!@dbparam use_sol_Ox_cycle if =1, a cycle of ozone is appled to -!@+ o3year, as a function of the solar constant cycle. - INTEGER :: use_sol_Ox_cycle = 0 - REAL*8 :: S0min, S0max - -!@dbparam ozone_use_ppm_interp = 1 uses ppm interpolation in the -!@+ timestream. Otherwise uses linm2m. - INTEGER :: ozone_use_ppm_interp = 1 - -!@var have_o3_file whether an O3file was specified in the rundeck - LOGICAL :: have_o3_file - -!@param NLO3_traditional assumed number of layers in ozone data files. - INTEGER, PARAMETER :: NLO3_TRADITIONAL = 49 -!@var NLO3 number of layers in ozone data files, as read from file. - INTEGER :: NLO3 = 0 -!@var PLBO3_traditional assumed edge pressures in O3 input file. - REAL*8 :: PLBO3_traditional(NLO3_TRADITIONAL+1) & - & = (/984D0,934D0,854D0,720D0,550D0,390D0,285D0,210D0, & - & 150D0,125D0,100D0,80D0,60D0,55D0,50D0,45D0,40D0,35D0, & - & 30D0,25D0,20D0,15D0,10.D0,7.D0,5.D0,4.D0,3.D0,2.D0, & - & 1.5D0,1.D0,7D-1,5D-1,4D-1,3D-1,2D-1,1.5D-1,1D-1,7D-2, & - & 5D-2,4D-2,3D-2,2D-2,1.5D-2,1D-2,7D-3,5D-3,4D-3,3D-3, & - & 1D-3,1D-7/) -!@var PLBO3 edge pressures in O3 input file, as read from file - REAL*8, ALLOCATABLE :: PLBO3(:) - - - CONTAINS - - SUBROUTINE UPDO3D(JYEARO,JJDAYO,O3JDAY,O3JREF) - USE DICTIONARY_MOD - USE RESOLUTION, ONLY:psf - USE DOMAIN_DECOMP_ATM, ONLY:grid, GETDOMAINBOUNDS - USE TIMESTREAM_MOD, ONLY:INIT_STREAM, READ_STREAM, & - & GETNAME_FIRSTFILE - USE PARIO, ONLY:PAR_OPEN, PAR_CLOSE, READ_DIST_DATA, & - & VARIABLE_EXISTS, GET_DIMLEN, READ_DATA - USE FILEMANAGER, ONLY:FILE_EXISTS - IMPLICIT NONE - INTEGER, INTENT(IN) :: JYEARO, JJDAYO - REAL*8, DIMENSION(:,:,:), POINTER :: o3jday, o3jref - - INTEGER :: i, j, l, jyearx, fid - LOGICAL, SAVE :: init = .FALSE. - LOGICAL :: cyclic, exists - REAL*8, ALLOCATABLE :: o3arr(:,:,:) - CHARACTER(LEN=6) :: method - CHARACTER(LEN=32) :: fname1st - - INTEGER :: j_0, j_1, i_0, i_1 - - CALL GETDOMAINBOUNDS(grid,J_STRT=j_0,J_STOP=j_1,I_STRT=i_0, & - & I_STOP=i_1) - - jyearx = ABS(jyearo) - - IF ( .NOT.init ) THEN - init = .TRUE. - - have_o3_file = FILE_EXISTS('O3file') - - IF ( have_o3_file ) THEN - - ! Initialize the timestream for the O3 data file: - cyclic = jyearo<0 - - CALL SYNC_PARAM("ozone_use_ppm_interp",ozone_use_ppm_interp) - IF ( ozone_use_ppm_interp==1 ) THEN - method = 'ppm' - ELSE - method = 'linm2m' - ENDIF - CALL INIT_STREAM(grid,O3stream,'O3file','O3',0D0,1D30, & - & TRIM(method),jyearx,jjdayo,cyclic=cyclic) - ! query the layering - CALL GETNAME_FIRSTFILE(O3stream,fname1st) - fid = PAR_OPEN(grid,TRIM(fname1st),'read') - IF ( VARIABLE_EXISTS(grid,fid,'ple') ) THEN - nlo3 = GET_DIMLEN(grid,fid,'ple') - 1 - ! coord var but one less - IF ( nlo3/=GET_DIMLEN(grid,fid,'plm') ) & - & CALL STOP_MODEL('ple/plm dim problem in O3file', & - & 255) - ALLOCATE (plbo3(nlo3+1)) - CALL READ_DATA(grid,fid,'ple',plbo3,BCAST_ALL=.TRUE.) - ELSE - CALL STOP_MODEL('missing ple info in o3file',255) - ENDIF - CALL PAR_CLOSE(grid,fid) - ELSE - nlo3 = NLO3_TRADITIONAL - ALLOCATE (plbo3(nlo3+1)) - plbo3(:) = plbo3_traditional(:) - ENDIF - -#ifdef GCAP - ALLOCATE (save_to3(grid%I_STRT:grid%I_STOP,grid%J_STRT:grid% & - & J_STOP)) - save_to3 = 0. -#endif - - ALLOCATE (o3jday(nlo3,grid%I_STRT:grid%I_STOP,grid%J_STRT:grid%& - & J_STOP)) - o3jday = 0. - - ALLOCATE (o3jref(NLO3_TRADITIONAL,grid%I_STRT:grid%I_STOP, & - & grid%J_STRT:grid%J_STOP)) - o3jref = 0. - -! The next line is brought over from the original UPDO3D. I think -! it is to prevent "losing" some ozone in the REPART interpolation -! if the (fixed) lowest O3 level pressure is at lower pressure than -! the the (fixed) lowest nominal model pressure: - IF ( plbo3(1) g(O3)/g(air) = kg(O3)/kg(air). So now we have a mass - ! mixing ratio. Then multiply by the air mass in kg/m2: - ! kg(O3)/kg(air) * [kg(air)/m2] --> kg(O3)/m2. - ! - ! The demoninator is obtained starting with the density of ozone - ! at 1 atmosphere and 0 deg C. At those conditions, air density - ! is p/RT. I.e. p, R, T are constants here and reference Earth's - ! atmosphere: p=101325 Pa, R=rgas in J kg-1 K-1, T=tf in K, - ! so units work out to kg(air)/m3. Convert from air to ozone - ! again using the ratio of molecular weights, e.g. on Earth: - ! 1.2922 kg(air)/m3 * [48. g(O3)/n(O3) / 28.9655d g(air)/n(air)] - ! --> 2.1415 kg(O3)/m3. Note that this ratio of molecular weights - ! appears in the numerator and denominator so is skipped below. - ! - ! Now do numerator/denominator and obtain atm-m units, and - ! multiply by 100 to get the desired atm-cm units. This is the - ! cm thickness of O3 one would have under those those specific - ! atmoserpheric conditions. All that results in just: - - DO L = 1, LM - numerator = OxHFarr(i,j,L)*airmass(L) - ! kg O3 / m2 we have - denominator = 101325.D0/(rgas*tf) - ! kg O3 / m3 @ 1 atm and 0 deg C - OxHFarr_Converted(L) = 1.D2*numerator/denominator - ENDDO - - ! Now, interpolate vertically, but this interpolation is not onto - ! the rad code O3 levels, it is just an adjustment over the same - ! LM levels but allowing for different surface pressure than was - ! concurrent when this model input was saved from a previous run: - ! IN - CALL REPART(OxHFarr_Converted,filePressureBottoms,LM+1, & - & OxHFarr_Interpolated,modelPressureBottoms,LM+1) - ! OUT - ! save for use in rad code proper: - o3jday_HF_modelLevels(:,i,j) = OxHFarr_Interpolated(:) - ENDDO - ENDDO - - DEALLOCATE (OxHFarr,psf4o3arr) - - END SUBROUTINE UPDO3D_HIGHFREQUENCY -#endif /* HIGH_FREQUENCY_O3_INPUT */ - - - SUBROUTINE UPDO3D_SOLAR(jjdayo,S0,o3jday) -!@sum UPDO3D_solar adds solar cycle variability to O3JDAY - USE DICTIONARY_MOD - USE DOMAIN_DECOMP_ATM, ONLY:grid, GETDOMAINBOUNDS, AM_I_ROOT - USE TIMESTREAM_MOD, ONLY:INIT_STREAM, READ_STREAM - USE PARIO, ONLY:PAR_OPEN, PAR_CLOSE, READ_DATA - IMPLICIT NONE - INTEGER :: jjdayo - REAL*8 :: S0 - REAL*8, DIMENSION(:,:,:), POINTER :: o3jday -!@var delta_o3_now the difference in O3 between solar max and solar min, -!@+ interpolated to the current day - REAL*8, ALLOCATABLE :: delta_o3_now(:,:,:) -!@var add_sol is [S00WM2(now)-1/2(S00WM2min+S00WM2max)]/ -!@+ [S00WM2max-S00WM2min] so that O3(altered) = O3(default) + -!@+ add_sol*delta_O3_now - REAL*8 :: add_sol - LOGICAL, SAVE :: init = .FALSE. - INTEGER :: i, j, l, fid, jyearx - - INTEGER :: j_0, j_1, i_0, i_1 - - jyearx = 2000 ! nominal year - - IF ( .NOT.init ) THEN - init = .TRUE. - - CALL SYNC_PARAM("use_sol_Ox_cycle",use_sol_Ox_cycle) - - IF ( use_sol_Ox_cycle/=1 ) RETURN - - fid = PAR_OPEN(grid,'delta_O3','read') - CALL READ_DATA(grid,fid,'S0min',S0min,BCAST_ALL=.TRUE.) - CALL READ_DATA(grid,fid,'S0max',S0max,BCAST_ALL=.TRUE.) - CALL PAR_CLOSE(grid,fid) - - CALL INIT_STREAM(grid,delta_O3stream,'delta_O3','O3',-1D30, & - & 1D30,'linm2m',jyearx,jjdayo,CYCLIC=.TRUE.) - - ENDIF - - IF ( use_sol_Ox_cycle/=1 ) RETURN - - CALL GETDOMAINBOUNDS(grid,J_STRT=j_0,J_STOP=j_1,I_STRT=i_0, & - & I_STOP=i_1) - - add_sol = (S0-0.5D0*(S0min+S0max))/(S0max-S0min) - IF ( AM_I_ROOT() ) THEN - WRITE (6,661) JJDAYO, S0, S0min, S0max, add_sol - - 661 FORMAT ('JJDAYO,S0,S0min,S0max,frac=',I4,3F9.2,F7.3) - ENDIF - - ALLOCATE (delta_o3_now(grid%I_STRT_HALO:grid%I_STOP_HALO, & - & grid%J_STRT_HALO:grid%J_STOP_HALO,nlo3)) - - CALL READ_STREAM(grid,delta_O3stream,jyearx,jjdayo,delta_o3_now) - DO j = j_0, j_1 - DO i = i_0, i_1 - O3JDAY(:,I,J) = O3JDAY(:,I,J) + add_sol*delta_O3_now(i,j,:) - ENDDO - ENDDO - - DEALLOCATE (delta_o3_now) - END SUBROUTINE UPDO3D_SOLAR - - END MODULE O3MOD - - SUBROUTINE SET_FPXCO2(PL,FPXCO2,NL,KFPCO2) - USE FILEMANAGER, ONLY:FILE_EXISTS, OPENUNIT, CLOSEUNIT - USE DICTIONARY_MOD, ONLY:SYNC_PARAM, SET_PARAM - IMPLICIT NONE - INTEGER J, N, NL, iu, np, NCOL - REAL*8 PL(NL), FPXCO2(NL) - INTEGER, PARAMETER :: NCOLS = 4 - REAL*8 FPI, FPJ, PFI, PFJ, pf(NCOLS) - REAL*8, ALLOCATABLE :: FPX(:), PFP(:) - CHARACTER*80 title -!@dbparam KFPCO2 selects CO2 profile absorber scaling (if >0 ) - INTEGER :: KFPCO2 - ! KFPCO2 will be set from NL or from rundeck -! -! FPXCO2 scaling factors: 1.0 for P > 50mb, linear in P for P < 50mb -! PFP Pressure scale inflection points: continuous linear line segments -! PL=layerL mean pressure, FPXCO2=CO2 absorber scaling factor -! NL=total number of radiation layers incl. the top 3 rad. only layers -! -! CO2 profile absorber scaling: KFPCO2=0 FPXCO2=1, no scaling -! KFPCO2=1 FPXCO2: 43-layer scaling -! KFPCO2=2 FPXCO2: 99-layer scaling -! KFPCO2=3 FPXCO2: 105-layer scaling (2017) -! KFPCO2=4 FPXCO2: 105-layer scaling plus -! adjust up-flux corr. factors in top 10 layers -! KFPCO2<0 NL determines scaling -! KFPCO2>4 FPXCO2=1, no scaling - - CALL SYNC_PARAM("KFPCO2",KFPCO2) - - FPXCO2 = 1. ! default - -! KFPCO2>2 is reserved for a specific 102-layer modelE (used in year 2017) -! but may also work if the layering is the same above 50 mb; the criterion -! below only checks the number of layers above 50 mb - it may be necessary -! to specify KFPCO2 rather than rely on the automatic selection - IF ( NL>40 ) THEN - IF ( KFPCO2<0 .AND. ABS(PL(NL-38)-45.)<5. ) THEN - KFPCO2 = 4 - CALL SET_PARAM("KFPCO2",KFPCO2,'o') - ENDIF - ENDIF - IF ( KFPCO2>2 .OR. KFPCO2==0 ) RETURN - - IF ( .NOT.FILE_EXISTS('CO2profile') ) THEN - KFPCO2 = 0 - CALL SET_PARAM("KFPCO2",KFPCO2,'o') - RETURN - ENDIF - - CALL OPENUNIT('CO2profile',iu,.FALSE.,.TRUE.) - - READ (iu,'(a)') title - READ (title,*) np - READ (iu,'(a)') title - READ (iu,'(a)') title - READ (iu,'(a)') title - -! Find appropriate column for current layering - IF ( KFPCO2<0 ) THEN - IF ( nl<30 ) THEN - KFPCO2 = 0 - ELSEIF ( nl<80 ) THEN - KFPCO2 = 1 - ELSE - KFPCO2 = 2 - ENDIF - CALL SET_PARAM("KFPCO2",KFPCO2,'o') - ENDIF - - IF ( KFPCO2>2 .OR. KFPCO2<1 ) RETURN - - ncol = 2*KFPCO2 - 1 - - ALLOCATE (FPX(np),PFP(np)) - DO n = 1, np - READ (iu,*) pf - pfp(n) = pf(ncol) - fpx(n) = pf(ncol+1) - ENDDO - - CALL CLOSEUNIT(iu) - -! FPX CO2 scaling profile: (1.0 for P > 50mb) (linear in P for P < 50mb) - j = 1 - FPj = FPX(j) - PFj = PFP(j) - N = 1 - DO WHILE ( PL(N)>=PFj ) - FPXCO2(N) = FPj - N = N + 1 - IF ( N>NL ) GOTO 100 - ENDDO - - DO j = 2, np - FPI = FPj - PFI = PFj - FPj = FPX(j) - PFj = PFP(j) - DO WHILE ( PL(N)>=PFj ) - FPXCO2(N) = FPI - (FPI-FPj)*(PFI-PL(N))/(PFI-PFj) - N = N + 1 - IF ( N>NL ) GOTO 100 - ENDDO - ENDDO - - 100 DEALLOCATE (FPX,PFP) - END SUBROUTINE SET_FPXCO2 - - SUBROUTINE GET_FPXCO2_105(FPZCO2,JLAT,MLAT46,JDAY) - IMPLICIT NONE - INTEGER JLAT, MLAT46, JDAY - - INTENT (IN)JLAT, MLAT46, JDAY - INTENT (OUT)FPZCO2 ! FPZCO2 <==> FPXCO2 - - REAL*8 FPZCO2(39) - REAL*8, DIMENSION(39) :: FPZ_JAN, FPZ_JUL - REAL*8 REFLAT, WTJLAT, REFDAY, WTJDAY, WT1, WT2, WT3 - REAL*8, PARAMETER :: FPX_SPEQNP_JAN(39,3) & - & = RESHAPE((/0.106139D+01,0.106783D+01, & - & 0.106256D+01,0.106812D+01,0.106650D+01, & - & 0.105212D+01,0.100292D+01,0.978585D+00, & - & 0.973002D+00,0.104304D+01,0.103306D+01, & - & 0.969076D+00,0.958428D+00,0.101544D+01, & - & 0.100945D+01,0.993654D+00,0.991752D+00, & - & 0.979623D+00,0.941461D+00,0.937047D+00, & - & 0.928036D+00,0.909102D+00,0.900246D+00, & - & 0.901978D+00,0.874685D+00,0.890840D+00, & - & 0.947327D+00,0.980658D+00,0.101200D+01, & - & 0.102130D+01,0.727029D+00,0.750237D+00, & - & 0.856221D+00,0.852355D+00,0.991601D+00, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.795649D+00,0.704146D+00, & - & 0.727177D+00,0.792645D+00,0.748645D+00, & - & 0.872383D+00,0.778125D+00,0.761280D+00, & - & 0.769040D+00,0.762770D+00,0.787812D+00, & - & 0.795996D+00,0.812415D+00,0.806050D+00, & - & 0.931991D+00,0.879633D+00,0.936397D+00, & - & 0.942009D+00,0.914533D+00,0.932472D+00, & - & 0.905136D+00,0.880848D+00,0.810632D+00, & - & 0.878675D+00,0.901477D+00,0.951314D+00, & - & 0.101205D+01,0.109697D+01,0.105704D+01, & - & 0.120352D+01,0.128532D+01,0.152551D+01, & - & 0.107507D+01,0.993298D+00,0.993298D+00, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.105912D+01,0.104105D+01, & - & 0.103011D+01,0.101845D+01,0.991954D+00, & - & 0.980846D+00,0.948530D+00,0.898252D+00, & - & 0.900887D+00,0.931042D+00,0.913461D+00, & - & 0.885751D+00,0.882327D+00,0.962325D+00, & - & 0.978728D+00,0.984428D+00,0.997767D+00, & - & 0.974346D+00,0.962522D+00,0.951995D+00, & - & 0.935819D+00,0.925180D+00,0.923809D+00, & - & 0.912133D+00,0.915321D+00,0.915390D+00, & - & 0.905317D+00,0.931876D+00,0.976460D+00, & - & 0.974906D+00,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01/),(/39,3/)) - REAL*8, PARAMETER :: FPX_SPEQNP_JUL(39,3) & - & = RESHAPE((/0.101719D+01,0.988671D+00, & - & 0.986317D+00,0.992046D+00,0.979385D+00, & - & 0.962768D+00,0.917461D+00,0.884814D+00, & - & 0.904524D+00,0.954613D+00,0.967657D+00, & - & 0.923239D+00,0.926085D+00,0.942071D+00, & - & 0.948953D+00,0.923623D+00,0.947999D+00, & - & 0.894875D+00,0.928884D+00,0.938342D+00, & - & 0.904316D+00,0.906018D+00,0.893131D+00, & - & 0.876373D+00,0.869938D+00,0.849842D+00, & - & 0.890331D+00,0.913173D+00,0.933819D+00, & - & 0.880337D+00,0.853570D+00,0.710237D+00, & - & 0.826221D+00,0.772355D+00,0.991601D+00, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.813710D+00,0.718946D+00, & - & 0.774912D+00,0.764653D+00,0.790177D+00, & - & 0.781660D+00,0.768685D+00,0.778010D+00, & - & 0.742164D+00,0.823045D+00,0.810695D+00, & - & 0.809154D+00,0.839186D+00,0.890938D+00, & - & 0.912096D+00,0.957669D+00,0.940655D+00, & - & 0.970092D+00,0.949381D+00,0.925820D+00, & - & 0.904259D+00,0.919764D+00,0.842020D+00, & - & 0.892613D+00,0.930514D+00,0.978044D+00, & - & 0.972728D+00,0.108045D+01,0.115574D+01, & - & 0.121910D+01,0.135634D+01,0.165630D+01, & - & 0.109376D+01,0.991629D+00,0.991629D+00, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.109553D+01,0.103307D+01, & - & 0.101880D+01,0.104636D+01,0.105279D+01, & - & 0.103332D+01,0.974511D+00,0.948682D+00, & - & 0.946840D+00,0.100858D+01,0.997002D+00, & - & 0.924039D+00,0.896250D+00,0.963271D+00, & - & 0.977617D+00,0.996577D+00,0.992301D+00, & - & 0.974108D+00,0.947932D+00,0.929054D+00, & - & 0.928114D+00,0.912474D+00,0.912335D+00, & - & 0.915498D+00,0.901183D+00,0.925813D+00, & - & 0.971726D+00,0.104123D+01,0.110262D+01, & - & 0.120227D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01,0.100000D+01,0.100000D+01, & - & 0.100000D+01/),(/39,3/)) -! -! FPXCO2 scaling factors: 1.D0 for P>50mb, for layers 1-66 for NL=105 -! FPXCO2 scaling is applied only to the topmost 39 layers (67-105) -! PLZ=layerN layer-mean pressure, FPZCO2(N)=CO2 absorber scaling factor -! PLZ= input GCM variable PL(N), FPZCO2= output GCM variable FPXCO2(N) -! NL =total number of radiation layers (includes top 3 rad-only layers) -! -! #### operation details #### -!---------------------------------------------------------------------- -!x IF(KFPCO2.GE.3) CALL GET_FPXCO2_105(PL,FPXCO2,JLAT,MLAT46,JDAY) -!x -!x above CALL should be placed in RADIA inside the C**** MAIN J LOOP -!x CO2 absorber scaling in top 39 layers is JLAT and JDAY dependent. -!x Applicable for NL=105, scaling is invoked by KFPCO2=3 or KFPCO2=4 -!x -!x KFPCO2=4 invokes additional cooling rate control in top 10 layers -!x via CALL GET_DXTRU3_CORR in TAUGAS to adjust XTRU(96:105,3) coeff -!x -!x TAPER option is being utilized in TAUGAS -!x xtru(l,2:nrcf+1) = wt_one*1d0 + (1d0-wt_one)*xtru(l,2:nrcf+1) -!x xtrd(l,2:nrcf+1) = wt_one*1d0 + (1d0-wt_one)*xtrd(l,2:nrcf+1) -!x with: xtrd(l,2:nrcf+1) also now included (small smoothing effect) -!---------------------------------------------------------------------- - - FPZCO2 = 1.D0 - - REFLAT = MLAT46/2 - WTJLAT = JLAT/REFLAT - REFDAY = 183.D0 - WTJDAY = JDAY/REFDAY - - IF ( WTJLAT<1.D0 ) THEN - WT1 = 1.D0 - WTJLAT - IF ( WT1>0.9D0 ) WT1 = 1.D0 - WT2 = 1.D0 - WT1 - FPZ_JAN(:) = FPX_SPEQNP_JAN(:,1)*WT1 + FPX_SPEQNP_JAN(:,2)*WT2 - FPZ_JUL(:) = FPX_SPEQNP_JUL(:,1)*WT1 + FPX_SPEQNP_JUL(:,2)*WT2 - ELSE - WT2 = 2.D0 - WTJLAT - IF ( WT2<0.1D0 ) WT2 = 0.D0 - WT3 = 1.D0 - WT2 - FPZ_JAN(:) = FPX_SPEQNP_JAN(:,2)*WT2 + FPX_SPEQNP_JAN(:,3)*WT3 - FPZ_JUL(:) = FPX_SPEQNP_JUL(:,2)*WT2 + FPX_SPEQNP_JUL(:,3)*WT3 - ENDIF - - WT1 = ABS(1.D0-WTJDAY) - WT2 = 1.D0 - WT1 - FPZCO2(:) = FPZ_JAN(:)*WT1 + FPZ_JUL(:)*WT2 - - END SUBROUTINE GET_FPXCO2_105 - - SUBROUTINE GET_DXTRU3_CORR(DXTRU3_10,JLAT,MLAT46,JDAY) - IMPLICIT NONE - INTEGER JLAT, MLAT46, JDAY - - INTENT (IN)JLAT, MLAT46, JDAY - INTENT (OUT)DXTRU3_10 - - REAL*8 DXTRU3_10(10) - REAL*8, DIMENSION(10) :: DX3_JAN(10), DX3_JUL(10) - REAL*8 REFLAT, WTJLAT, REFDAY, WTJDAY, WT1, WT2, WT3 - - REAL*8, PARAMETER :: DXTRU3_SPEQNP_JAN(10,3) & - & = RESHAPE((/0.000000D+00,0.111138D-03, & - & 0.594676D-04,0.770460D-04,0.694530D-04, & - & 0.645742D-04,0.245626D-04,0.248727D-04, & - & -.520744D-05,0.165988D-04,0.000000D+00, & - & -.891406D-05,-.743531D-04,-.160635D-04, & - & -.119857D-04,0.873209D-05,0.473174D-05, & - & 0.158620D-04,0.548129D-05,0.121151D-04, & - & 0.000000D+00,-.176254D-04,-.395480D-04, & - & 0.200113D-04,0.172199D-04,-.661705D-05, & - & 0.399818D-04,0.130381D-04,0.198000D-04, & - & 0.263105D-04/),(/10,3/)) - REAL*8, PARAMETER :: DXTRU3_SPEQNP_JUL(10,3) & - & = RESHAPE((/0.000000D+00,0.120614D-04, & - & 0.809026D-05,0.473324D-05,0.482039D-05, & - & -.863633D-05,-.856459D-06,0.335398D-04, & - & 0.422371D-04,0.512790D-04,0.000000D+00, & - & 0.128452D-04,0.811048D-05,0.153064D-04, & - & 0.799234D-05,0.214280D-04,0.146487D-04, & - & 0.225772D-05,0.327750D-05,0.835161D-05, & - & 0.000000D-04,0.652637D-04,0.651595D-04, & - & 0.637362D-04,0.538371D-04,0.429989D-04, & - & 0.948327D-05,0.194748D-04,-.200184D-06, & - & 0.110353D-04/),(/10,3/)) - -! XTRU(L,3)= CO2 LW up-flux correction factor: layers 96-105 for NL=105 -! DXTRU3_SPEQNP(L,1)= SP region, DXTRU3(L,2)= EQ region, DXTRU3(L,3)=NP -! MLAT46=total number of latitude points, interpolation utilizes JLAT -! JDAY interpolation in time: (JDAY=1 =>JAN data) (JDAY=183 =>JUL data) -! -! #### operation details #### -!---------------------------------------------------------------------- -!x IF(KFPCO2.EQ.4) THEN -!x CALL GET_DXTRU3_CORR(DXTRU3_10,JLAT,MLAT46,JDAY) -!x XTRU(96:105,3)=1.D0+DXTRU3_10 -!x ENDIF -!x above CALL sequence should appear just before RETURN from TAUGAS -!---------------------------------------------------------------------- - - REFLAT = MLAT46/2 - WTJLAT = JLAT/REFLAT - REFDAY = 183.D0 - WTJDAY = JDAY/REFDAY - - IF ( WTJLAT<1.D0 ) THEN - WT1 = 1.D0 - WTJLAT - IF ( WT1>0.9D0 ) WT1 = 1.D0 - WT2 = 1.D0 - WT1 - DX3_JAN(:) = DXTRU3_SPEQNP_JAN(:,1) & - & *WT1 + DXTRU3_SPEQNP_JAN(:,2)*WT2 - DX3_JUL(:) = DXTRU3_SPEQNP_JUL(:,1) & - & *WT1 + DXTRU3_SPEQNP_JUL(:,2)*WT2 - ELSE - WT2 = 2.D0 - WTJLAT - IF ( WT2<0.1D0 ) WT2 = 0.D0 - WT3 = 1.D0 - WT2 - DX3_JAN(:) = DXTRU3_SPEQNP_JAN(:,2) & - & *WT2 + DXTRU3_SPEQNP_JAN(:,3)*WT3 - DX3_JUL(:) = DXTRU3_SPEQNP_JUL(:,2) & - & *WT2 + DXTRU3_SPEQNP_JUL(:,3)*WT3 - ENDIF - - WT1 = ABS(1.D0-WTJDAY) - WT2 = 1.D0 - WT1 - DXTRU3_10(:) = DX3_JAN(:)*WT1 + DX3_JUL(:)*WT2 - - END SUBROUTINE GET_DXTRU3_CORR diff --git a/model/RADIATION2.F90 b/model/RADIATION2.F90 deleted file mode 100644 index e17614b..0000000 --- a/model/RADIATION2.F90 +++ /dev/null @@ -1,9563 +0,0 @@ -#include "rundeck_opts.h" - -#ifndef SWFIX_20151201 -#define SWFIX_20151201 -#endif - - MODULE RADPAR -!@sum radiation module based originally on rad00b.radcode1.F -!@auth A. Lacis/V. Oinas/R. Ruedy -#ifndef USE_RAD_OFFLINE - USE CONSTANT, ONLY:pO2, AVOG, MAIR, GRAV, LOSCHMIDT_CONSTANT - USE ATM_COM, ONLY:LM_REQ - USE RESOLUTION, ONLY:LM_GCM => LM -#endif -#ifdef HEALY_LM_DIAGS - USE RESOLUTION, ONLY:JM_DIAG => JM -#endif - IMPLICIT NONE - -!-------------------------------------------------- -! Grid parameters: Vertical resolution/profiles -!-------------------------------------------------- - -!@var LX max.number of vertical layers of the radiation (1D)-model -!@+ -!@+ The Radiation Model can accomodate arbitrary vertical resolution, -!@+ the number of layers may be time or location dependent, -!@+ but it cannot exceed LX. -#ifndef USE_RAD_OFFLINE -!@+ The GCM uses LM_REQ radiative equilibrium layers on top of the LM -!@+ atmospheric layers - INTEGER, PARAMETER :: LX = LM_GCM + LM_REQ -#else - INTEGER, PARAMETER :: LX = 57 -#endif -! optional repartitioning of gases - OFFLINE use only -!@var MRELAY if not 0, gases/aerosols are repartitioned to new layering -!@var KEEP10 if =10 N2 is kept, not repartitioned (only if MRELAY>0) -!@+ n=1-9 N2 not repartitioned and replaces gas n -!@+ n=11-19 N2 not repartitioned and added to gas n-10 -!@var NO3COL if >0 ozone is rescaled before repartitioning if MRELAY>0 -!@var RO3COL = rescaled column amount of O3 if NO3COL>0 (if MRELAY>0) - INTEGER :: MRELAY = 0, KEEP10 = 0, NO3COL = 0 - REAL*8 :: RO3COL = 1. - -! temperature profile within a layer: TLB,TLM,TLT bottom,mid,top T -!@var TLGRAD if >=0 tlt=tlm+dT*TLGRAD, tlb=tlm-dT*TLGRAD where -!@+ dT is chosen to try to minimize discontinuities if TLGRAD=1 -!@+ if TLGRAD<0 tlt,tlm,tlb are all inputs (OFFLINE use) -!@var PTLISO tlt=tlb=tlm above PTLISO mb independent of TLGRAD - REAL*8 :: TLGRAD = 1. ! control param - REAL*8 :: PTLISO = 0D0 ! GCM control param - -!------------------------------------------- -! Grid parameters: Horizontal resolution -!------------------------------------------- - -!@var MLAT46,MLON72 horizontal grid dimensions referred to in this model -!@+ The Radiation Model utilizes Data with 72x46 (lon,lat) resolution. -!@+ For GCM resolution other than 72x46, set JLAT and ILON -!@+ to appropriately Sample (rather than interpolate) the -!@+ 72x46 aerosol, ozone, cloud heterogeneity data sets - INTEGER, PARAMETER :: MLAT46 = 46, MLON72 = 72 - -!@var JNORTH latitude index defining northern hemisphere : jlat>jnorth - INTEGER, PARAMETER :: JNORTH = MLAT46/2 - -! longitudes of box centers (degrees): -177.5,-172.5., ... ,177.5 -!@var DLAT46 latitudes of box centers (degrees) - REAL*8, PARAMETER :: DLAT46(46) & - = (/-90.,-86.,-82.,-78.,-74.,-70.,-66., & - -62.,-58.,-54.,-50.,-46.,-42.,-38.,-34., & - -30.,-26.,-22.,-18.,-14.,-10.,-6.,-2.,2., & - 6.,10.,14.,18.,22.,26.,30.,34.,38.,42.,46.,& - 50.,54.,58.,62.,66.,70.,74.,78.,82.,86., & - 90./) - -!---------------- -! Input data for the 1-d radiation -!---------------- - -!@var LASTVC if >= 0 picks sample atmosph. and ground data, OFFLINE only - INTEGER :: LASTVC = -123456 - -!@var COSZ cosine of zenith angle (1) - REAL*8 cosz -!@var JLAT,ILON lat,lon index w.r.to 72x46 lon-lat grid -!@var JGCM,IGCM host GCM grid indices -!@var NL,L1 highest and lowest above ground layer -!@var LS1_loc local tropopause level, used to limit H2O-scaling - INTEGER :: JLAT, ILON, NL, L1 = 1, LS1_loc - ! Offline deflts L1=LS1_loc=1 - INTEGER :: JGCM, IGCM -!@var JYEAR,JDAY current year, Julian date - INTEGER :: JYEAR = 1980, JDAY = 1 - -!@var PLB layer pressure (mb) at bottom of layer -!@var HLB height (km) at bottom of layer - currently NOT Used -!@var TLm mean layer temperature (K) -!@var TLb,TLt bottom,top layer temperature (K) - derived from TLm -!@+ (unless TLGRAD<0) -!@var SHL,RHL layer specific,relative humidity (1) - REAL*8, DIMENSION(LX+1) :: PLB, HLB, TLB - REAL*8, DIMENSION(LX) :: TLT, TLM, SHL, RHL -!@var KEEPRH if 0: find RH from SH, 1: find SH from RH, 2: keep both - INTEGER :: KEEPRH = 2 - -!@var ULGAS current gas amounts, 13 types (cm atm) (in getgas) -!@var TAUWC,TAUIC opt.depth of water,ice cloud layer (1) -!@var SIZEWC,SIZEIC particle size of water,ice clouds (micron) -!@var CLDEPS cloud heterogeneity; is computed using KCLDEP,EPSCON - REAL*8 :: ULGAS(LX,13), TAUWC(LX), TAUIC(LX), SIZEWC(LX), & - SIZEIC(LX), CLDEPS(LX) -!@var EPSCON cldeps=EPSCON if KCLDEP=1 -!@var KCLDEP KCLDEP=0->CLDEPS=0, 1->=EPSCON, 2->as is, 3,4->isccp - REAL*8 :: EPSCON = 0. - INTEGER :: KCLDEP = 4 ! control param - -!@var KDELIQ Flag for dry(0) or wet(1) air deliquescence - INTEGER :: KDELIQ(LX,4) -!@var KRHDTK if 1, RHlevel for deliquescence is temperature dependent - INTEGER :: KRHDTK = 1 - ! control parameter - -!@var SRBALB,SRXALB diffuse,direct surface albedo (1); see KEEPAL - REAL*8 :: SRBALB(6), SRXALB(6), dalbsn - ! prescr change in snowalbedo -!@var KEEPAL if 0, SRBALB,SRXALB are computed in SET/GETSUR - INTEGER :: KEEPAL = 0 ! control param -!@dbparm KSIALB sea ice albedo computation flag: 0=Hansen 1=Lacis - INTEGER :: KSIALB = 0 -!@var PVT frac. of surf.type (bareWhite+veg*8+bareDark+ocn)(1) -!@var AGESN 1-3 age of snow (over soil,oice,land ice) (days) -!@var SNOWLI amount of snow (over land ice) (kg/m^2) -!@var SNOWD amount of snow (over soil) (m) -!@var SNOWOI amount of snow (over ocean/lake ice) (kg/m^2) -!@var WEARTH soil wetness (1) -!@var WMAG wind speed (m/s) -!@var POCEAN fraction of box covered by ocean or lake (1) -!@var PLAKE fraction of box covered by lake (1) -!@var PEARTH fraction of box covered by soil (1) -!@var POICE fraction of box covered by ocean/lakeice (1) -!@var PLICE fraction of box covered by glacial ice (1) -!@var TGO top layer water temperature (K) of ocean/lake -!@var TGE,TGOI,TGLI top layer ground temperature (K) soil,seaice,landice -!@var TSL surface air temperature (K) - REAL*8 PVT(12), AGESN(3), SNOWD(2), SNOWOI, SNOWLI, WEARTH, WMAG, & - POCEAN, PEARTH, POICE, PLICE, PLAKE, TGO, TGE, TGOI, TGLI, & - TSL -!@var KZSNOW =1 for snow/ice albedo zenith angle dependence - INTEGER :: KZSNOW = 1 -! Additional info for Schramm/Schmidt/Hansen sea ice albedo KSIALB=0 -!@var ZSNWOI depth of snow over ocean ice (m) -!@var zoice depth of ocean ice (m) -!@var zmp depth of melt pond (m) -!@var fmp fraction of melt pond area (1) -!@var zlake lake depth (m) -!@var flags true if snow is wet -!@var snow_frac(2) fraction of snow over bare(1),vegetated(2) soil (1) -!@var snoage_fac_max max snow age reducing-factor for sea ice albedo - REAL*8 :: zsnwoi, zoice, zmp, fmp, zlake, snow_frac(2) - REAL*8 :: snoage_fac_max = .5D0 - -!@var ITRMAX maximum number of optional tracers - INTEGER, PARAMETER :: ITRMAX = 150 -!@var TRACER array to add up to ITRMAX additional aerosol species - REAL*8 :: TRACER(LX,ITRMAX) -!@var FSTOPX,FTTOPX switches on/off aerosol for diagnostics (solar,thermal component) -!@var FSTASC,FTTASC scales optional aerosols (solar,thermal component) - REAL*8 :: FSTOPX(ITRMAX), FTTOPX(ITRMAX) -!@var skip_AOD_in_rad If true, no optical depth calculations in RADIATION.f - LOGICAL :: skip_AOD_in_rad -!@var chem_IN column variable for importing ozone(1) and methane(2) -!@+ fields from rest of model -!@var use_tracer_chem:set U0GAS(L, )=chem_IN( ,L), L=L1,use_tracer_chem( ) -!@var GCCco2_IN column variable for importing CO2 and use_tracer_GCCco2 variable -#ifdef GCC_COUPLE_RAD - REAL*8 :: GCCco2_IN(LX) - INTEGER :: use_tracer_GCCco2 -#endif - REAL*8 :: chem_IN(2,LX) - INTEGER :: use_tracer_chem(2), use_o3_ref = 0 - LOGICAL*4 :: flags -!@var LOC_CHL local chlorophyll value (unit?) for albedo calculation (optional) - REAL*8 :: LOC_CHL -#ifdef HEALY_LM_DIAGS - REAL*8 :: VTAULAT(JM_DIAG) -#endif - - LOGICAL :: set_gases_internally = .TRUE., & - set_aerosols_internally = .TRUE. - -!@var U0GAS reference gas amounts, 13 types (cm atm) (in setgas) -! array with local and global entries: repeat this section in driver - REAL*8 U0GAS(LX,13) -! end of section to be repeated in driver (needed for 'copyin') - -!-------------------------------------------------------- -! Output data (from RCOMPX) grid point dependent -!-------------------------------------------------------- - -!@var TRDFLB,TRUFLB,TRNFLB Thrml down,up,net Flux at Layr Bottom (W/m2) -!@var SRDFLB,SRUFLB,SRNFLB Solar down,up,net Flux at Layr Bottom (W/m2) -!@var TRFCRL,SRFHRL layer LW Cooling Rate,SW Heating Rate (W/m2) -!@var SR.VIS,SR.NIR SW fluxes in vis,near-IR domain (W/m2) -!@var PLA...,ALB... planetary and surface albedos (1) -!@var TR...W,WINDZF fluxes in the window region (W/m2) -!@var BTEMPW,WINDZT Brightness temperature in the window region (K) -!@var SK...,SRK... Spectral breakdown of fluxes/heat.rates (W/m2) -!@var FSRNFG,FTRUFG surface type fractions of SW,LW fluxes (W/m2) -!@var DTRUFG not used (W/m2) -!sl!@var FTAUSL,TAUSL,... surface layer computations commented out: !sl -!@var LBOTCL,LTOPCL bottom and top cloud level (lbot < ltop) -!@var chem_out column variable for exporting radiation code quantities -!@ 1=Ozone, 2=aerosol ext, 3=N2O, 4=CH4,5=CFC11+CFC12 -!@var CO2outCol column CO2 export [mole mole-1] for SUBDD -!@var aesqex saves extinction aerosol optical thickness -!@var aesqsc saves scattering aerosol optical thickness -!@var aesqcb saves aerosol scattering asymmetry factor -!@var aesqex_dry saves dry extinction aerosol optical thickness -!@var aesqsc_dry saves dry scattering aerosol optical thickness -!@var aesqcb_dry saves dry aerosol scattering asymmetry factor - - REAL*8 TRDFLB(LX+1), TRUFLB(LX+1), TRNFLB(LX+1), TRFCRL(LX) - REAL*8 SRDFLB(LX+1), SRUFLB(LX+1), SRNFLB(LX+1), SRFHRL(LX) -!@var GCCco2_out column CO2 for exporting -#ifdef GCC_COUPLE_RAD - REAL*8 :: GCCco2_out(LX) = 0D0 -#endif - REAL*8 :: chem_out(LX,5) = 0D0 - REAL*8 :: CO2outCol(LX) = 0.D0 - REAL*8 SRIVIS, SROVIS, PLAVIS, SRINIR, SRONIR, PLANIR, SRDVIS, & - SRUVIS, ALBVIS, SRDNIR, SRUNIR, ALBNIR, SRTVIS, SRRVIS, & - SRAVIS, SRTNIR, SRRNIR, SRANIR - REAL*8 TRDFGW, TRUFGW, TRUFTW, BTEMPW, SRXVIS, SRXNIR - REAL*8 WINDZF(3), WINDZT(3), TOTLZF(3), TOTLZT(3) - REAL*8 SRKINC(16), SRKALB(16), SRKGAX(16,4), SRKGAD(16,4) - REAL*8, DIMENSION(LX,17) :: SKFHRL - REAL*8, DIMENSION(LX+1,17) :: SKDFLB, SKUFLB, SKNFLB - REAL*8 FSRNFG(4), FTRUFG(4), DTRUFG(4) - ! ,SRXATM(4) -!sl REAL*8 FTAUSL(33),TAUSL(33) ! surf.layer input data -!nu K ,TRDFSL,TRUFSL,TRSLCR,SRSLHR,TRSLWV !nu = not (yet) used -!sl K ,TRSLTS,TRSLTG,TRSLBS - REAL*8 aesqex(LX,6,ITRMAX), aesqsc(LX,6,ITRMAX), & - aesqcb(LX,6,ITRMAX) - REAL*8 aesqex_dry(LX,6,ITRMAX), aesqsc_dry(LX,6,ITRMAX), & - aesqcb_dry(LX,6,ITRMAX) - INTEGER :: LBOTCL, LTOPCL - -!---------------- scratch pad for temporary arrays that are passed to -! Work arrays other routines while working on a lat/lon point; -!---------------- but with openMP, each cpu needs its own copy !! - - REAL*8, DIMENSION(LX,6,8) :: nintaerext, nintaersca, nintaerasy - REAL*8, DIMENSION(LX,6) :: SRAEXT, SRASCT, SRAGCB, SRBEXT, & - SRBSCT, SRBGCB, SRDEXT, SRDSCT, & - SRDGCB, SRVEXT, SRVSCT, SRVGCB, & - SRCEXT, SRCSCT, SRCGCB, SRCPI0 - REAL*8, DIMENSION(LX+1,6) :: DBLEXT, DBLSCT, DBLGCB, DBLPI0 - REAL*8, DIMENSION(LX,33) :: TRTAUK, TRGXLK, TRCALK, TRAALK, & - TRBALK, TRDALK, TRVALK - REAL*8 DFLB(LX+1,33), UFLB(LX+1,33) - REAL*8, DIMENSION(33) :: TRCTCA, DFSL, UFSL, TXCTPG, TSCTPG, & - TGCTPG, AVH2S, TRGALB, BGFEMT, BGFEMD - REAL*8, DIMENSION(LX) :: PL, DPL, O2FHRL, SRAXNL, SRASNL, & - SRAGNL, O2FHRB - REAL*8 BXA(7), PRNB(6,4), PRNX(6,4), Q55H2S, QVH2S(6), SVH2S(6), & - GVH2S(6), XTRU(LX,4), XTRD(LX,4), DXAERU(LX,4,4,LX+4), & - DXAERD(LX,4,4,LX+4) - INTEGER IP24C9(LX) -!**** local except for special radiative aerosol diagnostics aadiag - - REAL*8 :: SRCQPI(6,15), TRCQPI(33,15) !??? to setcld/getcld - ! Temp data used by WRITER, WRITET - REAL*8 :: TRAQAB(33,11), TRBQAB(33,10), TRCQAB(33,15), & - TRDQAB(33,25) - REAL*8 :: AMP_TAB_SPEC(33,ITRMAX) - INTEGER :: NORDER(16), NMWAVA(16), NMWAVB(16) - -!------------------------------------------ -! Reference data, Tables, Climatologies -!------------------------------------------ - - REAL*8, PARAMETER :: DKS0(16) & - = (/.010,.030,.040,.040,.040,.002,.004, & - .013,.002,.003,.003,.072,.200,.480,.050, & - .011/) - - INTEGER :: NKSLAM = 14 - INTEGER, PARAMETER :: KSLAM(16) & - = (/1,1,2,2,5,5,5,5,1,1,1,3,4,6,6,1/) - - ! Model parameters generated by RCOMP1 -! E ,QXDUST(6,8),QSDUST(6,8),QCDUST(6,8),ATDUST(33,8),QDST55(8) !?DST !ron - REAL*8 :: HLB0(LX+1), PLB0(LX+1), TLM0(LX), U0GAS3(LX), & - TKPFW(630), TKPFT(900), AO3(460), FPXCO2(LX), & - FPXOZO(LX), TRAX(LX,33,5), DBLN(30), TCLMIN - !nu ,PIAERO(10) - - LOGICAL :: dust_optics_initialized = .FALSE. - !ron - REAL*8, DIMENSION(:,:), ALLOCATABLE :: QXDUST, QSDUST, QCDUST, & - ATDUST !ron - REAL*8, DIMENSION(:), ALLOCATABLE :: QDST55 !ron - REAL*8, DIMENSION(:), ALLOCATABLE :: taucon_dust - -!@dbparam planck_tmin, planck_tmax temperature range for Planck function -!@+ lookup table. If the requested tmin is less than the default -!@+ value of 124 K, the lookup table is extrapolated at startup to -!@+ cover the requested range (same for tmax exceeding 373 K). - INTEGER :: planck_tmin = 1, planck_tmax = 800 - -!@var transmission_corrections whether to apply correction factors -!@+ to longwave transmission - LOGICAL :: transmission_corrections -! RADDAT_TR_SGP_TABLES read from radfile1, radfile2 - INTEGER, PARAMETER :: NGUX = 1024, NTX = 8, NPX = 19 - REAL*8, DIMENSION(NGUX,NTX,NPX) :: TAUTBL, TAUWV0, TAUCD0, & - TAUO30 - REAL*8 H2O(100), FCO2(100) - REAL*8, DIMENSION(1:800,33) :: PLANCK - REAL*8 XKCFC(12,8,17:20), ULOX(19,16), DUX(19,16), XTFAC(11,9) -! Correction-factor lookup-table sizes -! NLCF : number of layers in ref. atm. used to compute the table -! NWVCF : number of H2O vapor column amounts -! NUCF : number of column amounts for absorbers other than H2O -! NRCF : number of principal absorber regions (H2O, CO2, O3) - INTEGER, PARAMETER, PRIVATE :: NLCF = 43, NWVCF = 9, NUCF = 7, & - NRCF = 3 - REAL*8, DIMENSION(NLCF,NRCF) :: XTU0, XTD0 - REAL*8, DIMENSION(NLCF,NWVCF,NRCF) :: XTRUP, XTRDN, DXUP13, & - DXDN13 - REAL*8, DIMENSION(NLCF,NWVCF,NUCF,NRCF) :: DXUP2, DXUP3, DXUP6, & - DXUP7, DXUP8, DXUP9, DXDN2, DXDN3, DXDN6, DXDN7,& - DXDN8, DXDN9 -!--------------------------------------------------------------------- -! Default h2o continuum is Ma 2000. Other options: Ma 2004 -! Roberts, MT_CKD model (Mlawer/Tobin_Clough/Kneizys/Davies) -!--------------------------------------------------------------------- - REAL*8 H2OCN8(33,8,14), H2OCF8(33,8,5) - -! RADDAT_AERCLD_MIEPAR read from radfile3 - REAL*8 :: SRAQEX(6,11), SRAQSC(6,11), SRAQCB(6,11), Q55A11(11), & - TRAQEX(33,11), TRAQSC(33,11), TRAQCB(33,11), & - REFA11(11), SRBQEX(6,10), SRBQSC(6,10), SRBQCB(6,10), & - Q55B10(10), TRBQEX(33,10), TRBQSC(33,10), & - TRBQCB(33,10), REFB10(10), SRCQEX(6,15), SRCQSC(6,15),& - SRCQCB(6,15), Q55C15(15), TRCQEX(33,15), TRCQSC(33,15)& - , TRCQCB(33,15), REFC15(15), TRCQAL(33,15), VEFC15(15)& - , VEFA11(11), VEFB10(10), SRDQEX(6,25), SRDQSC(6,25), & - SRDQCB(6,25), Q55D25(25), YRDQEX(6,25), YRDQSC(6,25), & - YRDQCB(6,25), Y55D25(25), TRDQEX(33,25), TRDQSC(33,25)& - , TRDQCB(33,25), REFD25(25), TRDQAL(33,25), VEFD25(25)& - , SRVQEX(6,20,6), SRVQSC(6,20,6), SRVQCB(6,20,6), & - TRVQEX(33,20,6), TRVQSC(33,20,6), TRVQCB(33,20,6), & - TRVQAL(33,20,6), Q55V20(20,6), REFV20(20,6), & - VEFV20(20,6), SRUQEX(6,120), SRUQSC(6,120), & - SRUQCB(6,120), Q55U22(120), TRUQEX(33,120), & - TRUQSC(33,120), TRUQCB(33,120), REFU22(120), & - TRUQAL(33,120), VEFU22(120), TRSQAL(33,25), VEFS25(25)& - , SRSQEX(6,25), SRSQSC(6,25), SRSQCB(6,25), Q55S25(25)& - , TRSQEX(33,25), TRSQSC(33,25), TRSQCB(33,25), & - REFS25(25) - - REAL*8 SRQV(6,20), SRSV(6,20), SRGV(6,20), Q55V(20), REFV(20) - REAL*8 TRQV(33,20), TRSV(33,20), TRGV(33,20), TRAV(33,20), & - VEFV(20) - EQUIVALENCE (SRVQEX(1,1,6),SRQV(1,1)) - EQUIVALENCE (SRVQSC(1,1,6),SRSV(1,1)) - EQUIVALENCE (SRVQCB(1,1,6),SRGV(1,1)) - EQUIVALENCE (Q55V20(1,6),Q55V(1)) - EQUIVALENCE (TRVQEX(1,1,6),TRQV(1,1)) - EQUIVALENCE (TRVQSC(1,1,6),TRSV(1,1)) - EQUIVALENCE (TRVQCB(1,1,6),TRGV(1,1)) - EQUIVALENCE (TRVQAL(1,1,6),TRAV(1,1)) - EQUIVALENCE (REFV20(1,6),REFV(1)) - EQUIVALENCE (VEFV20(1,6),VEFV(1)) - -! RADDAT_CLDCOR_TRSCAT read from radfileE - REAL*8 :: RIJTPG(6,49,17,21), FDXTPG(3,49,17,21), & - FEMTPG(3,49,17,21) - -!@var ppmv_to_cm_at_stp Conversion factor for conversion from PPMV to cm at -! STP. Also needs an additional factor dP for the -! conversion. - REAL*8, PARAMETER :: PPMV_TO_CM_AT_STP = 1.0D-05*AVOG/ & - (GRAV*MAIR*LOSCHMIDT_CONSTANT) -!@var h2o_mmr_to_cm_at_stp Conversion factor for conversion from mass -! mixing ratio to cm at STP for water vapor. -! Also needs an additional factor dP for the -! conversion. - REAL*8, PARAMETER :: H2O_MMR_TO_CM_AT_STP = PPMV_TO_CM_AT_STP* & - 1.0D+06*MAIR/18.0153D0 - - -!-------------------------------------- This also should be moved out -! History files (+ control options) of RADPAR, which should just -!-------------------------------------- have to handle 1 point in time - -! -------------------------------------------------------i/o control -!@var MADxxx Model Add-on Data of Extended Climatology Enable Parameter -!@+ ------ if 0 input process is skipped -!@+ 2 MADAER = 1 Reads Aerosol tropospheric climatology -!@+ 3 MADDST = 1 Reads Dust-windblown mineral climatology RFILE6 -!@+ 4 MADVOL = 1 Reads Volcanic 1950-00 aerosol climatology RFILE7 -!@+ 5 MADEPS = 1 Reads Epsilon cloud heterogeneity data RFILE8 -!@+ 6 MADLUV = 1 Reads Lean format Spectral Solar Irrad. RFILE9 -!@+ MADGHG = 1 Enables UPDGHG update. MADGHG=0: no update -!@+ MADSUR = 1 Reads Vegetation,Topography data RFILEC,RFILED -!@+ MADBAK if 1 Adds background aerosols -!@+ MADO2A if > 0 call set/geto2a, activating O2 solar heating -! ------------------------------------------------------------------ - INTEGER :: MADO3M = 1, MADAER = 0, MADDST = 0, MADVOL = 0, & - MADEPS = 0, MADLUV = 1 - INTEGER :: MADGHG = 1, MADSUR = 0, MADBAK = 0 - ! MADSUR=1 for OFF-line use - INTEGER :: MADO2A = 1 - -! ------------------------------------------------------time control -!@var KYEARx,KJDAYx if both are 0 : data are updated to current yr/day -!@+ ------------- only KJDAYx=0: data cycle through year KYEARx -!@+ neither is 0 : yr/day=KYEARx/KJDAYx data are used -!@+ KYEARS,KJDAYS: Solar Trend -!@+ KYEARO,KJDAYO: Ozone Trend -!@+ KYEARD,KJDAYD: Dust Trend -!@+ KYEARE,KJDAYE: CldEps Trend -!@+ KYEARG,KJDAYG: GHG Trend -!@+ KYEARR,KJDAYR: RVegeTrend (Ground Albedo) -!@+ KYEARV,KJDAYV: Volc.Aerosol Trend -!@+ KYEARA,KJDAYA: trop.Aerosol Trend -! ------------------------------------------------------------------ - INTEGER :: KYEARS = 0, KJDAYS = 0, KYEARG = 0, KJDAYG = 0, & - KYEARO = 0, KJDAYO = 0, KYEARA = 0, KJDAYA = 0, & - KYEARD = 0, KJDAYD = 0, KYEARV = 0, KJDAYV = 0, & - KYEARE = 0, KJDAYE = 0, KYEARR = 0, KJDAYR = 0 - - REAL*8, DIMENSION(:,:,:), POINTER :: o3jday, o3jref -#ifdef HIGH_FREQUENCY_O3_INPUT - REAL*8, DIMENSION(:,:,:), POINTER :: o3jday_HF_modelLevels -#endif - -!@var PLBA21 Vert. Layering for tropospheric aerosols (reference) - REAL*8, PARAMETER :: PLBA20(21) & - = (/984.,964.,934.,884.,810.,710.,550., & - 390.,285.,210.,150.,110.,80.,55.,35.,20., & - 10.,3.,1.,0.3,0.1/) -!@var PLBA09 Vert. Layering for tropospheric aerosols/dust (reference) - REAL*8, PARAMETER :: PLBA09(10) & - = (/1010.,934.,854.,720.,550.,390.,255., & - 150.,70.,10./) - REAL*8, DIMENSION(:), POINTER :: plbaer => null() - REAL*8, DIMENSION(:,:,:,:), POINTER :: A6JDAY => null() - - -! RADMAD3_DUST_SEASONAL (user SETDST) radfile6 -! REAL*4 TDUST(72,46,9,8,12) !ron -! REAL*8 DDJDAY(9,8,72,46) !ron - -! RADMAD4_VOLCAER_DECADAL (user SETVOL) radfile7 - INTEGER JVOLYI, JVOLYE, NVOLMON, NVOLLAT, NVOLK - REAL*8, DIMENSION(:), ALLOCATABLE :: ELATVOL, HVOLKM - REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: VTauTJK - ! (NVOLMON,NVOLLAT,NVOLK) - REAL*8, DIMENSION(:,:), ALLOCATABLE :: VReffTJ ! (NVOLMON,NVOLLAT) - - -! RADMAD5_CLDEPS_3D_SEASONAL (user SETCLD) radfile8 - REAL*4 EPLMHC(72,46,12,4) - REAL*8 EPLOW(72,46), EPMID(72,46), EPHIG(72,46), EPCOL(72,46) - -! RADMAD6_SOLARUV_DECADAL (user SETSOL) radfile9 -!@var iy1S0,MS0X first year, max.number of months for S0 history -!@var icycs0 solar cycle in yrs used to extend S0 history before 2000 -!@var icycs0f solar cycle in yrs used to extend S0 history after 2000 -!@var KSOLAR controls which data are used: <0 Thekaekara, else Lean: -!@+ 1: use monthly data, 2: use annual data, 0: constant data -!@+ 9: use annual data from file but with Thekaekara bins - INTEGER :: KSOLAR = 2 ! MADLUV=KSOLAR=0 only possible OFF-line - - INTEGER, PARAMETER :: IY1S0 = 1882, MS0X = 12*(1998-IY1S0+1) - INTEGER, PARAMETER :: ICYCS0 = 11, ICYCS0F = 12 - INTEGER iMS0X - REAL*4 yr1S0, yr2S0 - REAL, ALLOCATABLE, DIMENSION(:,:) :: UV_SSI - REAL, ALLOCATABLE, DIMENSION(:) :: TSI1, TSI2 - REAL*8 FS_SSI(190), W1_SSI(190) - - REAL*8 :: S00WM2 = 1366.2911D0, S0 = 1366.D0, RATLS0 = 1. - - REAL*8 :: WSOLAR(190), FSOLAR(190) - -!*** alternate sources to get WSOLAR,FSOLAR: - REAL*8, DIMENSION(190) :: WS_SSI, DS_SSI, FR_SSI -#ifdef USE_RAD_OFFLINE - COMMON /LEAN1950/ WS_SSI, DS_SSI, FR_SSI - ! for MADLUV=0 uses block data -#endif - REAL*8, PARAMETER :: WTHEK(190) & - = (/.115,.120,.125,.130,.140,.150,.160, & - .170,.180,.190,.200,.210,.220,.225,.230, & - .235,.240,.245,.250,.255,.260,.265,.270, & - .275,.280,.285,.290,.295,.300,.305,.310, & - .315,.320,.325,.330,.335,.340,.345,.350, & - .355,.360,.365,.370,.375,.380,.385,.390, & - .395,.400,.405,.410,.415,.420,.425,.430, & - .435,.440,.445,.450,.455,.460,.465,.470, & - .475,.480,.485,.490,.495,.500,.505,.510, & - .515,.520,.525,.530,.535,.540,.545,.550, & - .555,.560,.565,.570,.575,.580,.585,.590, & - .595,.600,.605,.610,.620,.630,.640,.650, & - .660,.670,.680,.690,.700,.710,.720,.730, & - .740,.750,.760,.770,.780,.790,.800,.810, & - .820,.830,.840,.850,.860,.870,.880,.890, & - .900,.910,.920,.930,.940,.950,.960,0.97, & - 0.98,0.99,1.00,1.05,1.10,1.15,1.20,1.25, & - 1.30,1.35,1.40,1.45,1.50,1.55,1.60,1.65, & - 1.70,1.75,1.80,1.85,1.90,1.95,2.00,2.10, & - 2.20,2.30,2.40,2.50,2.60,2.70,2.80,2.90, & - 3.00,3.10,3.20,3.30,3.40,3.50,3.60,3.70, & - 3.80,3.90,4.00,4.10,4.20,4.30,4.40,4.50, & - 4.60,4.70,4.80,4.9,5.0,6.0,7.0,8.0,9.0, & - 10.0,11.0,12.0,13.0,14.0,15.00/) - ! if KSOLAR<0 - - REAL*8, PARAMETER :: FTHEK(190) & - = (/.007,.900,.007,.007,.030,.070,.230, & - .630,1.25,2.71,10.7,22.9,57.5,64.9,66.7, & - 59.3,63.0,72.3,70.4,104.,130.,185.,232., & - 204.,222.,315.,482.,584.,514.,603.,689., & - 764.,830.,975.,1059.,1081.,1074.,1069., & - 1093.,1083.,1068.,1132.,1181.,1157.,1120., & - 1098.,1098.,1189.,1429.,1644.,1751.,1774., & - 1747.,1693.,1639.,1663.,1810.,1922.,2006., & - 2057.,2066.,2048.,2033.,2044.,2074.,1976., & - 1950.,1960.,1942.,1920.,1882.,1833.,1833., & - 1852.,1842.,1818.,1783.,1754.,1725.,1720., & - 1695.,1705.,1712.,1719.,1715.,1712.,1700., & - 1682.,1666.,1647.,1635.,1602.,1570.,1544., & - 1511.,1486.,1456.,1427.,1402.,1389.,1344., & - 1314.,1290.,1260.,1235.,1211.,1185.,1159., & - 1134.,1109.,1085.,1060.,1036.,1013.,990., & - 968.,947.,926.,908.,891.,880.,869.,858., & - 847.,837.,820.,803.,785.,767.,748.,668., & - 593.,535.,485.,438.,397.,358.,337.,312., & - 288.,267.,245.,223.,202.,180.,159.,142., & - 126.,114.,103.,90.,79.,69.0,62.0,55.0,48.0,& - 43.0,39.0,35.0,31.0,26.0,22.6,19.2,16.6, & - 14.6,13.5,12.3,11.1,10.3,9.5,8.70,7.80, & - 7.10,6.50,5.92,5.35,4.86,4.47,4.11,3.79, & - 1.82,0.99,.585,.367,.241,.165,.117,.0851, & - .0634,.0481/) - -!icb RADMAD7_VEG_TOPOG (user SETSUR) radfileC,radfileD -!icb FVEG11(72,46,11),FOLGIZ(72,46,9) - -! RADMAD8_RELHUM_AERDATA (user SETAER,SETREL) radfileH -!nu KRHAER(4) -1/0/1 flag to base aeros.sizes on 70%/0%/model rel.humi -!nu INTEGER :: KRHAER(4)=(/1,1,1,1/) ! SO4,SSalt,NO3,OC -!@var KRHTRA(ITRMAX) 0/1 to make tracer aerosols rel.humid dependent - INTEGER :: KRHTRA(ITRMAX) = 1 - REAL*8 :: SRHQEX(6,190,4), SRHQSC(6,190,4), SRHQCB(6,190,4), & - TRHQAB(33,190,4), RHINFO(190,15,4), & - SRTQEX(6,190,ITRMAX), SRTQSC(6,190,ITRMAX), & - SRTQCB(6,190,ITRMAX), TRTQAB(33,190,ITRMAX), & - RTINFO(190,15,ITRMAX) - -!new -!new save TSOIL,TVEGE (not implemented) -!nu DIMENSION PI0TRA(11) -!new save FTRUFS,FTRUFV,DTRUFS,DTRUFV (not implemented) - -! ----------------------- -! Ozone absorption tables -! ----------------------- - REAL*8, PARAMETER :: XWAVO3(226) & - = (/.2002,.2012,.2022,.2032,.2042,.2052, & - .2062,.2072,.2082,.2092,.2102,.2112,.2122, & - .2132,.2142,.2152,.2162,.2172,.2182,.2192, & - .2202,.2212,.2222,.2232,.2242,.2252,.2262, & - .2272,.2282,.2292,.2302,.2312,.2322,.2332, & - .2342,.2352,.2362,.2372,.2382,.2392,.2400, & - .2402,.2412,.2422,.2432,.2438,.2444,.2452, & - .2458,.2463,.2472,.2478,.2482,.2490,.2492, & - .2500,.2508,.2519,.2527,.2539,.2543,.2553, & - .2562,.2566,.2571,.2575,.2579,.2587,.2597, & - .2604,.2617,.2624,.2635,.2643,.2650,.2654, & - .2662,.2669,.2675,.2682,.2692,.2695,.2702, & - .2712,.2718,.2722,.2732,.2742,.2746,.2752, & - .2762,.2772,.2782,.2792,.2802,.2812,.2822, & - .2830,.2842,.2852,.2862,.2872,.2882,.2892, & - .2902,.2912,.2922,.2932,.2942,.2952,.2962, & - .2972,.2982,.2992,.2998,.3004,.3016,.3021, & - .3029,.3036,.3037,.3051,.3053,.3059,.3061, & - .3066,.3075,.3077,.3083,.3085,.3092,.3098, & - .3100,.3104,.3106,.3109,.3112,.3130,.3135, & - .3146,.3148,.3151,.3154,.3167,.3170,.3173, & - .3176,.3190,.3194,.3199,.3200,.3209,.3210, & - .3216,.3220,.3223,.3226,.3239,.3242,.3245, & - .3248,.3253,.3255,.3269,.3272,.3275,.3279, & - .3292,.3295,.3299,.3303,.3309,.3312,.3328, & - .3332,.3334,.3338,.3357,.3365,.3369,.3372, & - .3391,.3395,.3398,.3401,.3417,.3421,.3426, & - .3430,.3437,.3439,.3451,.3455,.3460,.3463, & - .3466,.3472,.3481,.3485,.3489,.3493,.3499, & - .3501,.3506,.3514,.3521,.3523,.3546,.3550, & - .3554,.3556,.3561,.3567,.3572,.3573,.3588, & - .3594,.3599,.3600,.3604,.3606,.3639,.3647, & - .3650,.3654,.3660/) - REAL*8 :: UVA(226) - REAL*8, PARAMETER :: FUVKO3(226) & - = (/8.3,8.3,8.1,8.3,8.6,9.0,9.7,10.8,11.7, & - 13.0,14.3,16.0,18.0,20.6,23.0,26.1,29.3, & - 32.6,36.9,40.8,46.9,51.4,56.7,63.4,69.1, & - 76.6,84.0,91.4,99.9,110.0,118.0,126.0, & - 136.0,145.0,154.0,164.0,175.0,186.0,192.0, & - 201.0,210.0,212.0,221.0,230.0,239.0,248.0, & - 250.0,259.0,264.0,264.0,273.0,277.0,275.0, & - 283.0,283.0,290.0,283.0,297.0,290.0,300.0, & - 290.0,302.0,295.0,283.0,293.0,290.0,286.0, & - 297.0,281.0,280.0,271.0,275.0,254.0,264.0, & - 250.0,248.0,242.0,228.0,230.0,216.0,213.0, & - 211.0,199.0,188.0,188.0,178.0,169.0,153.0, & - 155.0,148.0,136.0,127.0,117.0,108.0,97.0, & - 88.7,81.3,78.7,67.9,61.4,54.3,49.6,43.1, & - 38.9,34.6,30.2,27.5,23.9,21.0,18.6,16.2, & - 14.2,12.3,10.7,9.5,8.880,7.520,6.960,6.160,& - 5.810,5.910,4.310,4.430,4.130,4.310,4.020, & - 3.330,3.390,3.060,3.100,2.830,2.400,2.490, & - 2.330,2.320,2.120,2.200,1.436,1.595,1.074, & - 1.138,1.068,1.262,0.818,0.948,0.860,1.001, & - 0.543,0.763,0.665,0.781,0.382,0.406,0.373, & - 0.608,0.484,0.601,0.209,0.276,0.259,0.470, & - 0.319,0.354,0.131,0.223,0.185,0.339,0.080, & - 0.093,0.079,0.184,0.139,0.214,0.053,0.074, & - 0.068,0.152,0.038,0.070,.0540000,.1030000, & - .0240000,.0382500,.0292500,.0550000, & - .0135000,.0155250,.0127500,.0188250, & - .0167250,.0262500,.0115500,.0140250, & - .0099750,.0115500,.0081000,.0104250, & - .0050100,.0057000,.0046650,.0073425, & - .0051825,.0055275,.0040575,.0077700, & - .0048900,.0054600,.0015375,.0017775, & - .0013275,.0014100,.0011550,.0023325, & - .0018825,.0019650,.0009600,.0013650, & - .0011925,.0013200,.0008925,.0009825, & - .0001350,.0006300,.0004500,.0006225,0.0/) - -! ------------------------------------------------------------------ -! NO2 Trace Gas Vertical Distribution and Concentration Profile -! ------------------------------------------------------------------ - - REAL*8, PARAMETER :: CMANO2(42) & - = (/8.66E-06,5.15E-06,2.85E-06,1.50E-06, & - 9.89E-07,6.91E-07,7.17E-07,8.96E-07, & - 3.67E-06,4.85E-06,5.82E-06,6.72E-06, & - 7.77E-06,8.63E-06,8.77E-06,8.14E-06, & - 6.91E-06,5.45E-06,4.00E-06,2.67E-06, & - 1.60E-06,8.36E-07,3.81E-07,1.58E-07, & - 6.35E-08,2.57E-08,1.03E-08,4.18E-09, & - 1.66E-09,6.57E-10,2.58E-10,1.02E-10, & - 4.11E-11,1.71E-11,7.73E-12,9.07E-12, & - 4.63E-12,2.66E-12,1.73E-12,1.28E-12, & - 1.02E-12,1.00E-30/) - ! every 2 km starting at 0km - -! ------------------------------------------------------------------ -! TRACE GAS REFERENCE AMOUNTS DISTRIBUTIONS ARE DEFINED IN SETGAS -! ------------------------------------------------------------------ - -!------------------------- -! Scaling/kill factors -!------------------------- - -!@var FULGAS scales the various atmospheric constituents: -!@+ H2O CO2 O3 O2 NO2 N2O CH4 F11 F12 N2C CFC11 CFC12 SO2 -!@+ Note: FULGAS(1) only acts in the stratosphere (unless LS1_loc=1) - -! H2O CO2 O3 O2 NO2 N2O CH4 F11 F12 N2C CFC11+ CFC12+ SO2 -! 1 2 3 4 5 6 7 8 9 10 11 12 13 - REAL*8 :: FULGAS(13) = (/1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1., & - 0./) ! scales ULGAS -#ifdef ALTER_RADF_BY_LAT -!@var FULGAS_orig saves initial FULGAS values - REAL*8, DIMENSION(13) :: FULGAS_orig -#endif - -!@var FGOLDH scales background aerosols for Glb Ocn Land Desert Haze -! GLOBAL OCEAN LAND DESERT HAZE -! for setbak/getbak only 1 2 3 4 5 - REAL*8 :: FGOLDH(5) = (/1D0,.68D0,.32D0,1.D-20,1.D-20/) - -!@var FSxAER,FTxAER scales solar,thermal opt.depth for var. aerosols: -!@+ x = T:total B:background A:atmClim D:dust V:volcanic - REAL*8 :: FSTAER = 1., FSBAER = 1., FSAAER = 1., FSDAER = 1., & - FSVAER = 1., FTTAER = 1., FTBAER = 1., FTAAER = 1., & - FTDAER = 1., FTVAER = 1. - -!@var FTAUC factor to control cloud optical depth in radiation calc. -!@+ =1 for full expression, =0 for clear sky calculation. - REAL*8 :: FTAUC - ! to be set in calling routine, thread-private ! deflt=1 - -!@var PIVMAX limits PI0 of volcanic aerosols - REAL*8 :: PIVMAX = 1.0 -!@var ECLTRA,KCLDEM scales,enables full cloud scattering correction - REAL*8 :: ECLTRA = 1. - INTEGER :: KCLDEM = 1 -!@var FCLDTR,FCLDSR scales opt.depth of clouds - not used (yet) -!@var FRAYLE scales Rayleigh parameter - REAL*8 :: FCLDTR = 1., FCLDSR = 1., FRAYLE = 1. - -!@var KUVFAC,UVFACT,UVWAVL,KSNORM rescale UV spectral flux distribution - INTEGER :: KUVFAC = 0, KSNORM = 0 - ! no rescaling - REAL*8 :: UVWAVL(3) = (/0.295D0,0.310D0,0.366D0/) - REAL*8 :: UVFACT(3) = (/0.98011D0,0.99467D0,0.99795D0/) - -!@var SRCGSF Scaling Factors for Cloud Asymmetry Parameter for -!@+ Water Ice MieIce - REAL*8 :: SRCGSF(3) = (/1.000,1.000,1.000/) - -!@var TAUWC0,TAUIC0 lower limits for water/ice cloud opt.depths - REAL*8 :: TAUWC0 = 1D-3, TAUIC0 = 1D-3 - -!@var KFPCO2,KPFOZO if > 0 scale CO2,O3 vertical profile - INTEGER :: KFPCO2 = -1, KPFOZO = 0 - -!@var KANORM,KCNORM if > 0 renormalize aerosols,cloud albedos - INTEGER :: KANORM = 0, KCNORM = 0 - -!@var KWVCON ON/OFF flag for water vapor continuum absorption -!@var KUFH2O,KUFCO2 H2O,CO2 column absorb.scaling -!@var KCSELF,KCFORN H2O_ContSelf-Broadening,CO2_ContForeign-Broadening - INTEGER :: KWVCON = 1, KUFH2O = 1, KUFCO2 = 1, KCSELF = 1, & - KCFORN = 1 -!@var XCSELF,XCFORN scaling factors for Cont.Broadening (Deflt: Ma 2000) - REAL*8 :: XCSELF = 1., XCFORN = 1. - -!@var ICE012 pick ice droplet type: 0 liquid, 1 ice non-spher, 2 ice Mie - INTEGER :: ICE012 = 1 - -!@var VEFF0 effective volc. aerosol size distribution variance - REAL*8 :: VEFF0 = 0.35D0, REFF0 = 0.30D0 ! REFF0 not used - -!@var NORMS0 if =1, Incident (TOA) Solar flux is normalized to equal S0 - INTEGER :: NORMS0 = 1 - -!@var fOnOff if =1 fully turns on SW long-path H2O absorption correction - REAL*8 :: fOnOff = 1. - ! if =0. disables SW-H2O correction (tunable) - -!@var KORDER,KWTRAB controls WRITER-output (Mie-scattering info) - INTEGER :: KWTRAB = 0, KORDER = 0 - -!----------------------------------------------------------------------- -! COMPOSITION VERTICAL DISTRIBUTION FOR 5 SPECIFIED AEROSOL TYPES -!----------------------------------------------------------------------- -! TYPE -! 1 STRATOSPHERIC GLOBAL AEROSOL A,B,C ARE GLOBAL AVERAGE VALUES -! 2 TROPOSPHERIC OCEAN AEROSOL A,B,C ARE GLOBAL AVERAGE VALUES -! 3 TROPOSPHERIC LAND AEROSOL A,B,C ARE GLOBAL AVERAGE VALUES -! 4 TROPOSPHERIC DESERT AEROSOL A,B,C ARE LOCAL AVERAGE VALUES -! 5 TROPOSPHERIC HAZE AEROSOL A,B,C ARE LOCAL AVERAGE VALUES - -! 1 2 3 4 5 6 7 8 9 10 11 -! ACID1 SSALT SLFT1 SLFT2 BSLT1 BSLT2 DUST1 DUST2 DUST3 CARB1 CARB2 - REAL*8, DIMENSION(11,5) :: AGOLDH = reshape((/.005,.0,.0,.0,.0, & - .0,.0,.0,.0,.0,.0,.0,.020,.010,.010, & - .005,.0,.010,.0,.0,.005,.0,.0,.0,.0, & - .020,.005,.0,.010,.010,.0,.0,.015,.0,& - .0,.0,.0,.0,.0,.0,.020,.010,.0,.0,.0,& - .0,.0,.010,.0,.0,.0,.0,.0,.0,.005/), & - (/11,5/)) - REAL*8, DIMENSION(11,5) :: BGOLDH = reshape((/20.0,.0,.0,.0,.0, & - .0,.0,.0,.0,.0,.0,.0,1.00,4.00,1.00, & - 4.00,1.00,4.00,.0,.0,1.00,.0,.0,.0, & - .0,0.00,2.00,.0,4.00,2.00,.0,.0,0.00,& - .0,.0,.0,.0,.0,.0,.0,2.00,0.00,.0,.0,& - .0,.0,.0,.0,.0,.0,.0,.0,.0,.0,0.00/),& - (/11,5/)) - REAL*8, DIMENSION(11,5) :: CGOLDH = reshape((/3.00,.0,.0,.0,.0, & - .0,.0,.0,.0,.0,.0,.0,1.00,3.00,2.00, & - 3.00,1.00,2.00,.0,.0,1.00,.0,.0,.0, & - .0,1.00,3.00,.0,1.00,1.00,.0,.0,1.00,& - .0,.0,.0,.0,.0,.0,.0,1.00,1.00,.0,.0,& - .0,.0,.0,1.00,.0,.0,.0,.0,.0,.0, & - 1.00/),(/11,5/)) - -!nu REAL*8, dimension(11) :: PI0VIS=(/ -!nu 1 2 3 4 5 6 -!nu ACID1 SSALT SLFT1 SLFT2 BSLT1 BSLT2 -!nu 1 1.00000, 1.00000, 1.00000, 1.00000, 0.98929, 0.95609, -!nu -!nu 7 8 9 10 11 -!nu DUST1 DUST2 DUST3 CARB1 CARB2 -!nu 2 0.91995, 0.78495, 0.63594, 0.31482, 0.47513/) - -! TROPOSPHERIC AEROSOL COMPOSITIONAL/TYPE PARAMETERS -! SO4 SEA ANT OCX BCI BCB DST VOL - -!nu * ,REFWET=(/0.272, 1.808, 0.398, 0.318, 0.100, 0.100, 1.000,1.000/) -!Koch DRYM2G=(/5.000, 2.866, 8.000, 8.000, 9.000, 9.000, 1.000,1.000/) -!nu RHTMAG=(/1.788, 3.310, 1.756, 1.163, 1.000, 1.000, 1.000,1.000/) -!nu alt RHTMAG=(/1.982, 3.042, 1.708, 1.033, 1.000, 1.000, 1.000,1.000/) -!old * WETM2G=(/8.345, 2.866, 7.811, 5.836, 9.000, 9.000, 1.000,1.000/) -!nu * ,WETM2G=(/9.250, 2.634, 7.598, 5.180, 9.000, 9.000, 1.000,1.000/) - - REAL*8, DIMENSION(8) :: REFDRY = (/0.150,1.000,0.300,0.200, & - 0.080,0.080,1.000,1.000/), & - Q55DRY = (/2.191,2.499,3.069,3.010, & - 1.560,1.560,1.000,1.000/), & - DENAER = (/1.760,2.165,1.725,1.500, & - 1.300,1.300,2.000,2.000/) - -! TROP AEROSOL 1850 BACKGROUND, INDUSTRIAL BIO-BURNING PARAMETERS -! TROPOSPHERIC AEROSOL COMPOSITIONAL/TYPE PARAMETERS -! SO4 SEA ANT OCX BCI BCB DST VOL - - - - REAL*8, DIMENSION(8) :: FS8OPX = (/1.000,1.000,1.000,1.000, & - 1.500,1.500,1.000,1.00/), & - FT8OPX = (/1.000,1.000,1.000,1.000, & - 1.000,1.000,1.300,1.00/), & - FRSULF = (/0.000,0.000,0.000,0.330, & - 0.000,0.000,0.000,1.00/), & - PI0MAX = (/1.000,1.000,1.000,1.000, & - 1.000,1.000,1.000,1.00/) - -!nu * ,A8VEFF=(/ .200, .200, .200, .200, .200, .200, .200, .200/) - -#ifdef ALTER_RADF_BY_LAT -!@var FS8OPX_orig saves initial FS8OPX values -!@var FT8OPX_orig saves initial FT8OPX values - REAL*8, DIMENSION(8) :: FS8OPX_orig, FT8OPX_orig -#endif - -! REAL*8, dimension(8) :: !ron -! MINERAL DUST PARAMETERS -! CLAY SILT -! *REDUST=(/0.132D0,0.23D0,0.416D0,0.766D0,1.386D0,2.773D0,5.545D0, !ron -! 8D0/) ! <- not used; 3 silt only !ron -!nu * ,VEDUST=(/ 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/) -! * ,RODUST=(/2.5D0,2.5D0,2.5D0,2.5D0,2.65D0,2.65D0,2.65D0, !ron -! 2.65D0/)! <- not used; 3 silt only !ron -!nu * ,FSDUST=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0/) -!nu * ,FTDUST=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0/) - -!@var DUSTAB: specifies relative mixture of particles with Sinyuk 2003 -!@+ and Patterson 1977 SW properties. -!@+ DUSTAB=1.0: all particles have Sinyuk 2003 properties -!@+ DUSTAB=0.0: all particles have Patterson 1977 properties - REAL*8, PARAMETER :: DUSTAB = 0.5 - -!----------------------------------------------------------------------- -! GHG 1980 Reference Concentrations and Vertical Profile Definitions -!----------------------------------------------------------------------- - -!@var KTREND if > 0 table GHG concentrations (Trend G) are used for -!@+ yr/day KYEARG/KJDAYG; if KTREND=0, GHG are set to PPMVK0 - INTEGER :: KTREND = 1 - -!@var PPMV80 reference GHG concentrations (ppm) -! GAS NUMBER 1 2 3 4 5 6 7 -! H2O CO2 O3 O2 NO2 N2O CH4 -#ifdef V2_O2_MODE /* temporary option to exactly match v2_branch */ - REAL*8, DIMENSION(13) :: PPMV80 = (/0D0,337.90D0,0D0,21D4,0D0, & - .3012D0,1.5470D0,.1666D-03,.3003D-03, & - 0D0,.978D-04,.0010D-10,.0420D0/) -#else - REAL*8, DIMENSION(13) :: PPMV80 = (/0D0,337.90D0,0D0,pO2*1.D6, & - 0D0,.3012D0,1.5470D0,.1666D-03, & - .3003D-03,0D0,.978D-04,.0010D-10, & - .0420D0/) -#endif -! CCL3F1 CCL2F2 N2 CFC-Y CFC-Z SO2 -! GAS NUMBER 8 9 10 11 12 13 - -!@var PPMVK0 user set GHG concentrations (ppm), used if KTREND=0 -! GAS NUMBER 1 2 3 4 5 6 7 -! H2O CO2 O3 O2 NO2 N2O CH4 - REAL*8, DIMENSION(12) :: PPMVK0 = (/0D0,337.90D0,0D0,21.D4,0D0, & - .3012D0,1.5470D0,.1666D-03,.3003D-03, & - 0D0,.978D-04,0.0010D-10/) -! CCL3F1 CCL2F2 N2 CFC-Y CFC-Z -! GAS NUMBER 8 9 10 11 12 - -! Makiko GHG Trend Compilation GHG.1850-2050.Dec1999 in GTREND -! --------------------------------------------------------------- -!@var nghg nr. of well-mixed GHgases: CO2 N2O CH4 CFC-11 CFC-12 others -!@var nyrsghg max.number of years of prescr. greenhouse gas history - INTEGER, PARAMETER :: NGHG = 6 - -!@var ghgyr1,ghgyr2 first and last year of GHG history - INTEGER ghgyr1, ghgyr2 -!@var ghgam,xref,xnow GHG-mixing ratios in ppm,ppm,ppm,ppb,ppb,ppb - REAL*8 XREF(NGHG+1), XNOW(NGHG+1) - REAL*8, ALLOCATABLE :: ghgam(:,:) - -! GTREND: 1980., 337.9, .3012, 1.547, .1666, .3003, .0978, -! --------------------------------------------------------------- - -!@var KGGVDF,KPGRAD,KLATZ0 control parameters for vertical GHG profiles -!@+ ----------------------------------------------------------------- -!@+ Minschwaner et al JGR (1998) CH4, N2O, CFC-12 Vertical profiles -!@+ IF(KGGVDF > 0) Then: -!@+ Gas decreases are linear with pressure, from unity at ground to -!@+ the fractional value PPMVDF(NGAS) at the top of the atmosphere. -!@+ Exponential decrease by EXP(-(Z-Z0)/H) is superimposed on this. -!@+ IF(KLATZ0 > 0) Then: Z0 depends on latitude, KGGVDF not used -!@+ KPGRAD>0: Pole-to-Pole lat. gradient (PPGRAD) is also superimposed -!@+ ------------------------------------------------------------------ -!@var Z0,ZH scale heights used for vertical profile (km) -!@var PPMVDF frac. value at top of atmosphere (used if KGGVDF > 0) -!@var PPGRAD Pole-to-Pole latitud.gradient for GHG (used if KPGRAD > 0) - INTEGER :: KGGVDF = 0, KPGRAD = 1, KLATZ0 = 1 - -! NUMBER 1 2 3 4 5 6 7 8 9 10 11 12 -! H2O CO2 O3 O2 NO2 N2O CH4 CFC11 CFC12 N2 CF-Y CF-Z - -! GAS NUMBER 1 2 3 4 5 6 7 -! H2O CO2 O3 O2 NO2 N2O CH4 -! CCL3F1 CCL2F2 N2 CFC-Y CFC-Z -! GAS NUMBER 8 9 10 11 12 - -! GAS NUMBER 1 2 3 4 5 6 7 -! H2O CO2 O3 O2 NO2 N2O CH4 - REAL*8, DIMENSION(12) :: Z0 = (/0.0,0.0,0.0,0.0,0.0,16.,16.,16.,& - 16.,0.0,16.,16./), & - ZH = (/8.0,8.0,8.0,8.0,8.0,30.,50.,30.,& - 30.,0.0,30.,30./), & - PPMVDF = (/1.0,1.0,1.0,1.0,1.0,0.88888,& - 0.88888,0.88888,0.88888,1.0,0.88888, & - 0.88888/), & - PPGRAD = (/0.0,0.0,0.0,0.0,0.0,0.0100, & - 0.0900,0.0600,0.0600,0.0,0.0600, & - 0.0600/) -! CCL3F1 CCL2F2 N2 CFC-Y CFC-Z -! GAS NUMBER 8 9 10 11 12 - -!--------------------- -! Optional Tracers used via setbak/getbak -!--------------------- - INTEGER, DIMENSION(ITRMAX) :: ITR = 1 - INTEGER :: NTRACE = 0 - -! TRACER AEROSOL COMPOSITIONAL/TYPE PARAMETERS -!nu * ,TRVEFF= .2d0 -!loc * ,FSTOPX= 1.d0 -!loc * ,FTTOPX= 1.d0 - REAL*8, DIMENSION(ITRMAX) :: TRRDRY = .1D0, TRADEN = 1.D0, & - FSTASC = 1.D0, FTTASC = 1.D0 - - SAVE - - CONTAINS - - SUBROUTINE RCOMP1(NRFUN) - USE DOMAIN_DECOMP_ATM, ONLY:AM_I_ROOT, grid - USE PARIO, ONLY:PAR_OPEN, PAR_CLOSE, VARIABLE_EXISTS, GET_DIMLEN, & - READ_DATA - USE FILEMANAGER, ONLY:FILE_EXISTS - - IMPLICIT NONE -! ------------------------------------------------------------------ -! Solar,GHG Trend, VolcAer Size Selection Parameters: Defaults -! Process KYEARX KJDAYX -! SolarCon, UV 0 0 -! GH Gas Trend 0 0 -! REFF0= 0.3 -! VEFF0= 0.35 -! ------------------------------------------------------------------ - -! NRFUN is now set as an argument from calling routine so that unit -! numbers can be set automatically - INTEGER :: NRFUN(14) -! radfile1 2 3 4 5 6 7 8 9 A B C D E -!? DATA NRFN0/71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84/ - - INTEGER, SAVE :: IFIRST = 1 - ! ,NRFN0 - CHARACTER*80 EPSTAG, TITLE - - REAL*4 OZONLJ(44,46), R72X46(72,46) - REAL*4, DIMENSION(:,:), ALLOCATABLE :: VTAUR4 !rjh - REAL*4, ALLOCATABLE :: vtau4(:,:,:), vreff4(:,:), hv4(:), & - lat4(:) - - INTEGER :: I, J, K, L, M, N, N1, N2, NRFU, KK, NN, IYEAR, & - IMONTH, JJDAYS, JYEARS, JJDAYG, JYEARG, yr2S0i - REAL*8 :: WAVNA, WAVNB, PFWI, TKOFPF, SUMV, EPK, EPL, DEP, & - SFNORM, D, O, Q, S, OCM, WCM, YQSCCB -!@var GTAU,TGDATA temporary array to read data and pass it to RAD_UTILS - REAL*8 :: GTAU(51,11,143), TGDATA(122,13) - - INTEGER :: N_BIN, fid - REAL*8, ALLOCATABLE, DIMENSION(:,:) :: SSI_IN - REAL*8, ALLOCATABLE, DIMENSION(:) :: calyear, WS_IN, DS_IN, & - TSI_IN - LOGICAL :: have_RADN9_file - -!? IF(LASTVC > 0) NRFUN=NRFN0 - IF ( IFIRST>=1 ) THEN - -! ------------------------------------------------------------------ -! Input data are read as specified in the first CALL RCOMP1 (NRFUN). -! Subsequent calls to RCOMP1 can be used to re-initialize parameters -! in SETXXX subroutines to different values, but no new data is read -! ------------------------------------------------------------------ - -! ------------------------------------------------------------------ -! MADVEL Model Add-on Data of Extended Climatology Enable Parameter -! Each MADVEL digit is ON/OFF switch for corresponding input -! e.g. MADVEL=123456 (zero digit skips input process) -! -! MADO3M = 1 Reads Decadal Ozone files and Ozone trend file -! MADAER = 2 Reads Aerosol 50y tropospheric climatology RFILE5 -! MADDST = 3 Reads Dust-windblown mineral climatology RFILE6 -! MADVOL = 4 Reads Volcanic 1950-00 aerosol climatology RFILE7 -! MADEPS = 5 Reads Epsilon cloud heterogeneity data RFILE8 -! MADLUV = 6 Reads Lean formar Solar Spectral Irrad. RFILE9 -! -! Related Model Add-on Data Parameters set in RADPAR -! -! MADGHG = 1 Default Enables UPDGHG update. (MADGHG=0),no update -! MADSUR = 1 Reads V72X46N.1.cor Vegetation type data RFILEC -! Z72X46N Ocean fraction, topography RFILED -! ------------------------------------------------------------------ - - -! Initialize variables that might not otherwise get defined -! --------------------------------------------------------- - - TAUWC(:) = 0 - TAUIC(:) = 0 - SIZEWC(:) = 0 - SIZEIC(:) = 0 - CLDEPS(:) = 0 - FPXCO2(:) = 1 - FPXOZO(:) = 1 - TLB(:) = 250 - TLT(:) = 250 - TLM(:) = 250 - SHL(:) = 0 - RHL(:) = 0 - SRAEXT(:,:) = 0 - SRASCT(:,:) = 0 - SRAGCB(:,:) = 0 - SRBEXT(:,:) = 0 - SRBSCT(:,:) = 0 - SRBGCB(:,:) = 0 - SRDEXT(:,:) = 0 - SRDSCT(:,:) = 0 - SRDGCB(:,:) = 0 - SRVEXT(:,:) = 0 - SRVSCT(:,:) = 0 - SRVGCB(:,:) = 0 - SRCEXT(:,:) = 0 - SRCSCT(:,:) = 0 - SRCGCB(:,:) = 0 - SRCPI0(:,:) = 0 - DBLPI0(:,:) = 0 - DBLEXT(:,:) = 0 - DBLSCT(:,:) = 0 - DBLGCB(:,:) = 0 - TRAALK(:,:) = 0 - TRBALK(:,:) = 0 - TRDALK(:,:) = 0 - TRVALK(:,:) = 0 - TRCALK(:,:) = 0 - TRGXLK(:,:) = 0 - U0GAS(:,:) = 0 - ULGAS(:,:) = 0 - TRACER(:,:) = 0 - EPLOW(:,:) = 0 - EPMID(:,:) = 0 - EPHIG(:,:) = 0 - - IF ( LASTVC>0 ) CALL SETATM - IF ( NL>LX ) CALL STOP_MODEL('rcomp1: increase LX',255) - -!**** Use (global mean) pressures to get standard mid-latitude summer -!**** values for height, density, temperature, ozone, water vapor - DO L = 1, NL + 1 - PLB0(L) = PLB(L) - CALL PHATMO(PLB0(L),HLB0(L),D,TLB(L),O,Q,S,OCM,WCM,1,2) - ENDDO - DO L = 1, NL - TLT(L) = TLB(L+1) - TLM(L) = 0.5D0*(TLB(L)+TLT(L)) - ENDDO - -!sl De-activate surface layer computations -!sl TAUSL(:)=0.0 -!sl FTAUSL(:)=0.0 - -!----------------------------------------------------------------------- -!R(1) Reads GTAU Asymmetry Parameter Conversion Table used within SGPGXG -! -! (SGPGXG does Multiple Scattering Parameterization used in SOLAR) -! ---------------------------------------------------------------- - - NRFU = NRFUN(1) - READ (NRFU) GTAU, TGDATA - CALL SETGTS(TGDATA) - CALL SET_SGPGXG(GTAU) - - -!----------------------------------------------------------------------- -!R(2) Reads in Merged k-Distribution Tau Tables for Thermal Radiation -! CFCs, H2O Continuum Tau Table, Merged k-Distr Planck Flux Table -! -! (Reads: TAUCD0,TAUTBL,TAUWV0,TAUO30,PLANCK,XKCFC,H2OCN8,H2OCF8 -! DUCH4,SDUCH4,DUN2O,SDUN2O,ULOX,DUX used in TAUGAS) -! ---------------------------------------------------------------- - - NRFU = NRFUN(2) - READ (NRFU) title, TAUTBL - READ (NRFU) title, TAUWV0 - READ (NRFU) title, TAUCD0 - READ (NRFU) title, TAUO30 - READ (NRFU) title, PLANCK - READ (NRFU) title, XKCFC - READ (NRFU) title, ULOX, DUX - - IF ( transmission_corrections ) THEN - NRFU = NRFUN(4) - READ (NRFU) title, XTRUP, XTRDN, XTU0, XTD0 - READ (NRFU) title, XTFAC - READ (NRFU) title, DXUP2, DXDN2 - ! CO2 - READ (NRFU) title, DXUP3, DXDN3 - ! O3 - READ (NRFU) title, DXUP6, DXDN6 - ! N2O - READ (NRFU) title, DXUP7, DXDN7 - ! CH4 - READ (NRFU) title, DXUP8, DXDN8 - ! CFC11 - READ (NRFU) title, DXUP9, DXDN9 - ! CFC12 - READ (NRFU) title, DXUP13, DXDN13 - ! SO2 - ENDIF - -!**** H2O Continuum Tau Tables (Ma_2000 or Ma_2004,Roberts,MT_CKD) - NRFU = NRFUN(5) - READ (NRFU) title, H2OCN8, XCSELF - IF ( AM_I_ROOT() ) WRITE (6,*) title, ' scaling factor:', & - XCSELF - READ (NRFU) title, H2OCF8, XCFORN - IF ( AM_I_ROOT() ) WRITE (6,*) title, ' scaling factor:', & - XCFORN - -! Define Window Flux to Brightness Temperature Conversion Factors -! --------------------------------------------------------------- - - DO i = 1, 100 - TKPFW(i) = TKOFPF(85D1,9D2,.001D0*I) - ENDDO - DO i = 1, 90 - TKPFW(i+100) = TKOFPF(85D1,9D2,.1D0+.01D0*I) - ENDDO - DO i = 1, 440 - TKPFW(i+190) = TKOFPF(85D1,9D2,1.D0+.1D0*I) - ENDDO - DO i = 1, 900 - TKPFT(i) = TKOFPF(0D0,1D4,DBLE(I)) - ENDDO - -! PLANCK Table interpolation limit parameters -! ------------------------------------------- -!----------------------------------------------------------------------- -!R(3) Read Mie Scattering Parameters [Qext, Qscat, AsymParameter] -! (1) Tropospheric Aerosols [11 Background, 8 Trop8 Aerosols] -! (2) Clouds [5 Water, 5 non-spherical Ice, 5 Mie Ice Clouds] -! (3) Desert Dust Aerosols [25 particle sizes - to select 8] -! (4) Volcanic Aerosols [20 particle sizes, 5 size variances] -! (5) Sulfate Aerosols [22 particle sizes, 0.1 - 10. micron] -! (6) Soot Aerosols [25 particle sizes, 0.001 - 5.0 micron] -! ----------------------------------------------------------- - - NRFU = NRFUN(3) - -! GCM 11 background aerosol Mie parameters -! ---------------------------------------- - DO N = 1, 11 - READ (NRFU,3000) TITLE - READ (NRFU,3001) (SRAQEX(K,N),K=1,6) - READ (NRFU,3001) (SRAQSC(K,N),K=1,6) - READ (NRFU,3001) (SRAQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3002) (Q55A11(N),N=1,11) - READ (NRFU,3003) (REFA11(N),N=1,11) - READ (NRFU,3003) (VEFA11(N),N=1,11) - DO N = 1, 11 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRAQEX(K,N),K=1,33) - READ (NRFU,3005) (TRAQSC(K,N),K=1,33) - READ (NRFU,3005) (TRAQCB(K,N),K=1,33) - ENDDO - -! GCM 9 (of 10) climatology aerosol Mie parameters -! ------------------------------------------------ - DO N = 1, 10 - IF ( N/=6 ) THEN - READ (NRFU,3000) TITLE - READ (NRFU,3001) (SRBQEX(K,N),K=1,6) - READ (NRFU,3001) (SRBQSC(K,N),K=1,6) - READ (NRFU,3001) (SRBQCB(K,N),K=1,6) - ENDIF - ENDDO - READ (NRFU,3002) (Q55B10(N),N=1,5), (Q55B10(N),N=7,10) - READ (NRFU,3003) (REFB10(N),N=1,5), (REFB10(N),N=7,10) - READ (NRFU,3003) (VEFB10(N),N=1,5), (VEFB10(N),N=7,10) - DO N = 1, 10 - IF ( N/=6 ) THEN - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRBQEX(K,N),K=1,33) - READ (NRFU,3005) (TRBQSC(K,N),K=1,33) - READ (NRFU,3005) (TRBQCB(K,N),K=1,33) - ENDIF - ENDDO - - -! Cloud Water, Ice-non, Ice-Mie parameters -! ---------------------------------------- - DO N = 1, 15 - READ (NRFU,3000) TITLE - READ (NRFU,3001) (SRCQEX(K,N),K=1,6) - READ (NRFU,3001) (SRCQSC(K,N),K=1,6) - READ (NRFU,3001) (SRCQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3006) (Q55C15(N),N=1,15) - 3006 FORMAT (18X,6(F7.5,1X)/18X,6(F7.5,1X)/18X,6(F7.5,1X)) - READ (NRFU,3007) (REFC15(N),N=1,15) - READ (NRFU,3007) (VEFC15(N),N=1,15) - DO N = 1, 15 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRCQEX(K,N),K=1,33) - READ (NRFU,3005) (TRCQSC(K,N),K=1,33) - READ (NRFU,3005) (TRCQCB(K,N),K=1,33) - READ (NRFU,3005) (TRCQAL(K,N),K=1,33) - ENDDO - -! Desert Dust 25 sizes, Mie parameter data -! ---------------------------------------- - DO N = 1, 25 - READ (NRFU,3001) (SRDQEX(K,N),K=1,6) - READ (NRFU,3001) (SRDQSC(K,N),K=1,6) - READ (NRFU,3001) (SRDQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3008) (Q55D25(N),N=1,25) - READ (NRFU,3009) (REFD25(N),N=1,25) - READ (NRFU,3010) (VEFD25(N),N=1,25) - DO N = 1, 25 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRDQEX(K,N),K=1,33) - READ (NRFU,3005) (TRDQSC(K,N),K=1,33) - READ (NRFU,3005) (TRDQCB(K,N),K=1,33) - READ (NRFU,3005) (TRDQAL(K,N),K=1,33) - ENDDO - - TRDQAB(:,:) = TRDQEX(:,:) - TRDQSC(:,:) - ! used in writer only - -! Volcanic aerosol Mie size, variance data -! ---------------------------------------- - DO M = 1, 5 - IF ( M/=4 ) THEN - DO N = 1, 20 - READ (NRFU,3001) (SRVQEX(K,N,M),K=1,6) - READ (NRFU,3001) (SRVQSC(K,N,M),K=1,6) - READ (NRFU,3001) (SRVQCB(K,N,M),K=1,6) - ENDDO - READ (NRFU,3011) (Q55V20(N,M),N=1,20) - 3011 FORMAT (18X,5(F7.5,1X),3(/18X,5(F7.5,1X))) - READ (NRFU,3012) (REFV20(N,M),N=1,20) - READ (NRFU,3012) (VEFV20(N,M),N=1,20) - DO N = 1, 20 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRVQEX(K,N,M),K=1,33) - READ (NRFU,3005) (TRVQSC(K,N,M),K=1,33) - READ (NRFU,3005) (TRVQCB(K,N,M),K=1,33) - READ (NRFU,3005) (TRVQAL(K,N,M),K=1,33) - ENDDO - ENDIF - ENDDO - DO N = 1, 20 - DO K = 1, 6 - SRVQEX(K,N,4) = (SRVQEX(K,N,3)+SRVQEX(K,N,5))/2.D0 - SRVQSC(K,N,4) = (SRVQSC(K,N,3)+SRVQSC(K,N,5))/2.D0 - SRVQCB(K,N,4) = (SRVQCB(K,N,3)+SRVQCB(K,N,5))/2.D0 - ENDDO - Q55V20(N,4) = (Q55V20(N,3)+Q55V20(N,5))/2.D0 - REFV20(N,4) = (REFV20(N,3)+REFV20(N,5))/2.D0 - VEFV20(N,4) = (VEFV20(N,3)+VEFV20(N,5))/2.D0 - DO K = 1, 33 - TRVQEX(K,N,4) = (TRVQEX(K,N,3)+TRVQEX(K,N,5))/2.D0 - TRVQSC(K,N,4) = (TRVQSC(K,N,3)+TRVQSC(K,N,5))/2.D0 - TRVQCB(K,N,4) = (TRVQCB(K,N,3)+TRVQCB(K,N,5))/2.D0 - TRVQAL(K,N,4) = (TRVQAL(K,N,3)+TRVQAL(K,N,5))/2.D0 - ENDDO - ENDDO - -! Sulfate aerosol, Mie parameter 22-size data -! ------------------------------------------- - DO N = 1, 22 - READ (NRFU,3000) TITLE - READ (NRFU,3001) (SRUQEX(K,N),K=1,6) - READ (NRFU,3001) (SRUQSC(K,N),K=1,6) - READ (NRFU,3001) (SRUQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3008) (Q55U22(N),N=1,22) - READ (NRFU,3013) (REFU22(N),N=1,22) - READ (NRFU,3013) (VEFU22(N),N=1,22) - DO N = 1, 22 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRUQEX(K,N),K=1,33) - READ (NRFU,3005) (TRUQSC(K,N),K=1,33) - READ (NRFU,3005) (TRUQCB(K,N),K=1,33) - READ (NRFU,3005) (TRUQAL(K,N),K=1,33) - ENDDO - -! Soot aerosol, Mie parameter 25-size data -! ---------------------------------------- - DO N = 1, 25 - READ (NRFU,3000) TITLE - READ (NRFU,3001) (SRSQEX(K,N),K=1,6) - READ (NRFU,3001) (SRSQSC(K,N),K=1,6) - READ (NRFU,3001) (SRSQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3008) (Q55S25(N),N=1,25) - READ (NRFU,3013) (REFS25(N),N=1,25) - READ (NRFU,3013) (VEFS25(N),N=1,25) - DO N = 1, 25 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRSQEX(K,N),K=1,33) - READ (NRFU,3005) (TRSQSC(K,N),K=1,33) - READ (NRFU,3005) (TRSQCB(K,N),K=1,33) - READ (NRFU,3005) (TRSQAL(K,N),K=1,33) - ENDDO - -! Seasalt aerosol, Mie parameter 22-size data -! Nitrate aerosol, Mie parameter 22-size data -! (Water) aerosol, Mie parameter 22-size data -! Organic aerosol, Mie parameter 22-size data -! ------------------------------------------- - N1 = 23 - DO KK = 1, 4 - N2 = N1 + 21 - DO N = N1, N2 - READ (NRFU,3000) TITLE - READ (NRFU,3001) (SRUQEX(K,N),K=1,6) - READ (NRFU,3001) (SRUQSC(K,N),K=1,6) - READ (NRFU,3001) (SRUQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3008) (Q55U22(N),N=N1,N2) - READ (NRFU,3013) (REFU22(N),N=N1,N2) - READ (NRFU,3013) (VEFU22(N),N=N1,N2) - N1 = N2 + 1 - ENDDO - N1 = 23 - DO KK = 1, 4 - N2 = N1 + 21 - DO N = N1, N2 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRUQEX(K,N),K=1,33) - READ (NRFU,3005) (TRUQSC(K,N),K=1,33) - READ (NRFU,3005) (TRUQCB(K,N),K=1,33) - READ (NRFU,3005) (TRUQAL(K,N),K=1,33) - ENDDO - N1 = N2 + 1 - ENDDO - -! Sinyuk Desert Dust 25 sizes, Mie parameter data -! ----------------------------------------------- - - DO N = 1, 25 - READ (NRFU,3001) (YRDQEX(K,N),K=1,6) - READ (NRFU,3001) (YRDQSC(K,N),K=1,6) - READ (NRFU,3001) (YRDQCB(K,N),K=1,6) - ENDDO - READ (NRFU,3008) (Y55D25(N),N=1,25) - READ (NRFU,3009) (REFD25(N),N=1,25) - READ (NRFU,3010) (VEFD25(N),N=1,25) - DO N = 1, 25 - READ (NRFU,3000) TITLE - READ (NRFU,3004) (TRDQEX(K,N),K=1,33) - READ (NRFU,3005) (TRDQSC(K,N),K=1,33) - READ (NRFU,3005) (TRDQCB(K,N),K=1,33) - READ (NRFU,3005) (TRDQAL(K,N),K=1,33) - ENDDO - - TRDQAB(:,:) = TRDQEX(:,:) - TRDQSC(:,:) - ! used in writer only - -!----------------------------------------------------------------------- -! Create external mixture of Patterson and Sinyuk dust particles - DO N = 1, 25 - DO K = 1, 6 - YQSCCB = YRDQSC(K,N)*YRDQCB(K,N)*DUSTAB + SRDQSC(K,N) & - *SRDQCB(K,N)*(1.D0-DUSTAB) - SRDQEX(K,N) = DUSTAB*YRDQEX(K,N) + (1.D0-DUSTAB) & - *SRDQEX(K,N) - SRDQSC(K,N) = DUSTAB*YRDQSC(K,N) + (1.D0-DUSTAB) & - *SRDQSC(K,N) - SRDQCB(K,N) = YQSCCB/(1.D-10+SRDQSC(K,N)) - ENDDO - Q55D25(N) = DUSTAB*Y55D25(N) + (1.D0-DUSTAB)*Q55D25(N) - ENDDO - -!----------------------------------------------------------------------- -!R(7) Read Stratospheric Volcanic binary data -! (NVOLMON months (years JVOLYI to JVOLYE) x NVOLLAT latitudes) -! If KyearV<0 use the NVOLMON-month mean as background aerosol -! --------------------------------------------------------- - NRFU = NRFUN(7) - IF ( madvol==1 ) THEN - READ (NRFU) TITLE, NVOLMON, JVOLYI, JVOLYE - NVolLat = 24 - NVolK = 4 - IF ( TITLE(1:9)/='OD Header' ) & - CALL STOP_MODEL('rcomp1: use new RADN7 header file', & - 255) - ALLOCATE (VTauTJK(NVOLMON,NVolLat,NVolK),HVolKM(NVolK+1)) - ALLOCATE (VReffTJ(NVOLMON,NVolLat),VTAUR4(NVOLMON,NVolLat)) - DO K = 1, NVolK - READ (NRFU) TITLE, VTAUR4 - DO J = 1, NVolLat - SUMV = 0. - DO I = 1, NVOLMON - VTauTJK(I,J,K) = VTAUR4(I,J) - SUMV = SUMV + VTAUR4(I,J) - ENDDO - IF ( kyearv<0 ) VTauTJK(1,J,K) = SUMV/NVOLMON - ENDDO - ENDDO - READ (NRFU) TITLE, VTAUR4 - DO J = 1, NVolLat - SUMV = 0. - DO I = 1, NVOLMON - VReffTJ(I,J) = VTAUR4(I,J) - SUMV = SUMV + VTAUR4(I,J) - ENDDO - IF ( kyearv<0 ) VReffTJ(1,J) = SUMV/NVOLMON - ENDDO - DEALLOCATE (VTAUR4) - ELSEIF ( madvol==2 ) THEN - READ (NRFU) TITLE - REWIND NRFU - IF ( TITLE(1:12)/='CMIP6 Header' ) & - CALL STOP_MODEL('rcomp1: use CMIP6 RADN7 header file',& - 255) - READ (NRFU) TITLE, NVOLMON, JVOLYI, JVOLYE, NVolLat, NVolK - ALLOCATE (VTauTJK(NVOLMON,NVolLat,NVolK)) - ALLOCATE (VTau4(NVOLMON,NVolLat,NVolK)) - ALLOCATE (VReff4(NVOLMON,NVolLat)) - ALLOCATE (VReffTJ(NVOLMON,NVolLat)) - ALLOCATE (HVOLKM(NVolK+1),ELATVOL(NVolLat+1)) - ALLOCATE (hv4(NVolK+1),LAT4(NVolLat+1)) - READ (NRFU) TITLE, VTau4 - VTauTJK = VTau4 - READ (NRFU) TITLE, VReff4 - VReffTJ = VReff4 - READ (NRFU) TITLE, hv4 - HVOLKM = hv4 - READ (NRFU) TITLE, LAT4 - ELATVOL = lat4 - DEALLOCATE (VTau4,VReff4,hv4,LAT4) - IF ( kyearv<0 ) THEN - DO j = 1, NVolLat - VReffTJ(1,J) = SUM(VReffTJ(:,j))/nvolmon - DO k = 1, NVolK - VTauTJK(1,J,K) = SUM(VTauTJK(:,j,k))/nvolmon - ENDDO - ENDDO - ENDIF - ENDIF -!----------------------------------------------------------------------- -!R(8) ISCCP Derived Cloud Variance (EPSILON) Cloud Optical Depth Factor -! Low, Mid, High Cloud Optical Depths are Reduced by (1 - EPSILON) -! -! INPUT DATA FILE: UNIT = INFILE -! TAG = EPSTAG (CHARACTER*80) -! DATA = EPLMHC (72,46,12,4) REAL*4 -! -! Data are 72X46 Monthly Mean Low, Mid, High, Column EPSILON Values -! Cloud Heterogeneity selections used in UPDEPS, GETEPS (in SETCLD) -! -! EPSCON Column Cloud Inhomogeneity EPSILON (when KCLDEP=1) -! KCLDEP Selects Cloud Inhomogeneity Option (0-4): -! KCLDEP = 0 Sets Column CLDEPS to Zero -! KCLDEP = 1 Sets Column CLDEPS to EPSCON -! KCLDEP = 2 Keeps whatever is specified in CLDEPS -! KCLDEP = 3 Uses: Column EPCOL(72,46) Climatology -! KCLDEP = 4 Uses: Ht Dep EPLOW, EPMID, EPHIG Data -! -------------------------------------------------------- - - IF ( MADEPS>=1 ) THEN - NRFU = NRFUN(8) - READ (NRFU) EPSTAG, EPLMHC - - - DO N = 1, 4 - DO M = 1, 12 - DO I = 1, 72 -!**** extend northern-most non-neg.value to N.Pole - J = 46 - ! MLAT46 - DO WHILE ( EPLMHC(I,J,M,N)<0 ) - J = J - 1 - ENDDO - IF ( J<46 ) EPLMHC(I,J+1:46,M,N) = EPLMHC(I,J,M,N) -!**** extend southern-most non-neg.value to S.Pole - J = 1 - DO WHILE ( EPLMHC(I,J,M,N)<0 ) - J = J + 1 - ENDDO - IF ( J>1 ) EPLMHC(I,1:J-1,M,N) = EPLMHC(I,J,M,N) - IF ( J/=46 ) THEN - DO -!**** linearly interpolate across remaining intervals with EP<0 - J = J + 1 ! find start of interval: - DO WHILE ( EPLMHC(I,J,M,N)>=0 ) - J = J + 1 - IF ( J>46 ) GOTO 810 - ENDDO - K = J - 1 - EPK = EPLMHC(I,K,M,N) - J = J + 1 ! find end of interval: - DO WHILE ( EPLMHC(I,J,M,N)<0 ) - J = J + 1 - ENDDO - L = J - EPL = EPLMHC(I,L,M,N) - ! EPk>=0, EPk+1,...,EPl-1<0, EPl>=0 - DEP = (EPL-EPK)/(L-K) - DO NN = 1, L - 1 - K - ! replace EP(k+1)...EP(l-1) - EPLMHC(I,K+NN,M,N) = EPK + NN*DEP - ENDDO - IF ( J>=46 ) EXIT - ENDDO - ENDIF - 810 ENDDO - ENDDO - ENDDO - ENDIF - - - -!----------------------------------------------------------------------- -!R(E) -! KCLDEM Selects: Top-Cloud (Thermal) Scattering Correction -! KCLDEM = 0 Utilizes Non-scattering approximation -! KCLDEM = 1 Modifies emission and transmission by -! top cloud (over-rides old correction) -! ---------------------------------------------------------- - - NRFU = NRFUN(14) - READ (NRFU) RIJTPG, FDXTPG, FEMTPG - - -!----------------------------------------------------------------------- -!R(9) Read Judith Lean Solar UV and Solar Constant Variability -! Monthly-Mean Solar UV -! --------------------------------- - iMS0X = MS0X - - IF ( KSOLAR>=0 ) THEN - IF ( MADLUV<1 ) THEN - WS_SSI(:) = WS_SSI(:)/1000.D0 - DS_SSI(:) = DS_SSI(:)/1000.D0 - W1_SSI(:) = WS_SSI(:) - 0.5D0*DS_SSI(:) - GOTO 949 - ENDIF -! NRFU=NRFUN(9) - -! IF(KSOLAR.ne.9) THEN -! READ(NRFU,'(a80)') TITLE -! if(ksolar >= 2 .and. TITLE(1:3).ne.'ANN') -! call stop_model('rcomp1: change RADN9 to ann.file',255) -! if(ksolar < 2 .and. TITLE(1:3)=='ANN') -! call stop_model('rcomp1: change RADN9 to monthly file',255) -! READ(NRFU,'(5F14.2)') WSLEAN ! 1:190 -! READ(NRFU,'(a80)') TITLE -! READ(NRFU,'(5E14.3)') DSLEAN ! 1:190 - - have_RADN9_file = FILE_EXISTS('RADN9') - - IF ( have_RADN9_file ) THEN - fid = PAR_OPEN(grid,'RADN9','read') - iMs0X = GET_DIMLEN(grid,fid,'time') - N_BIN = GET_DIMLEN(grid,fid,'wlen') - ALLOCATE (TSI_IN(iMS0X),calyear(iMS0X)) - ALLOCATE (WS_IN(N_BIN),DS_IN(N_BIN),SSI_IN(N_BIN,iMS0X)) - IF ( VARIABLE_EXISTS(grid,fid,'calyear') ) THEN - CALL READ_DATA(grid,fid,'calyear',calyear, & - BCAST_ALL=.TRUE.) - ELSE - CALL STOP_MODEL('missing calyear in RADN9 file',255) - ENDIF - IF ( VARIABLE_EXISTS(grid,fid,'wlen') ) THEN - CALL READ_DATA(grid,fid,'wlen',WS_IN,BCAST_ALL=.TRUE.) - ELSE - CALL STOP_MODEL( & - &'missing the wlen variable in RADN9 file'& - ,255) - ENDIF - IF ( VARIABLE_EXISTS(grid,fid,'wlenbinsize') ) THEN - CALL READ_DATA(grid,fid,'wlenbinsize',DS_IN, & - BCAST_ALL=.TRUE.) - ELSE - CALL STOP_MODEL('missing wlenbinsize in RADN9 file', & - 255) - ENDIF - IF ( VARIABLE_EXISTS(grid,fid,'ssi') ) THEN - CALL READ_DATA(grid,fid,'ssi',SSI_IN,BCAST_ALL=.TRUE.) - ELSE - CALL STOP_MODEL( & - &'missing the ssi variable in RADN9 file'& - ,255) - ENDIF - IF ( VARIABLE_EXISTS(grid,fid,'tsi') ) THEN - CALL READ_DATA(grid,fid,'tsi',TSI_IN,BCAST_ALL=.TRUE.) - ELSE - CALL STOP_MODEL( & - &'missing the tsi variable in RADN9 file'& - ,255) - ENDIF - CALL PAR_CLOSE(grid,fid) - ELSE - CALL STOP_MODEL('missing the RADN9 file',255) - ENDIF - - WS_SSI(:) = WS_IN(N_BIN-189:N_BIN)/1000.D0 - DS_SSI(:) = DS_IN(N_BIN-189:N_BIN)/1000.D0 - W1_SSI(:) = WS_SSI(:) - 0.5D0*DS_SSI(:) - -! WSLEAN(:)=WSLEAN(:)/1000.D0 -! DSLEAN(:)=DSLEAN(:)/1000.D0 -! W1LEAN(:)=WSLEAN(:)-0.5D0*DSLEAN(:) - -! READ(NRFU,'(a80)') TITLE -! READ(NRFU,'(a80)') TITLE -! READ(NRFU,'(a80)') TITLE -! if(TITLE(1:5).ne.'MS0X=') then ! old no_header file -! backspace (NRFU) -! else -! read (title(6:80),*) iMs0X -! endif -! END IF - ALLOCATE (UV_SSI(iMS0X,190),TSI1(iMS0X),TSI2(iMS0X)) - UV_SSI(:,:) = TRANSPOSE(SSI_IN(N_BIN-189:N_BIN,:)) - TSI1(:) = TSI_IN(:) - TSI2(:) = TSI_IN(:) - yr1S0 = calyear(1) - yr2S0 = calyear(iMS0X) - DEALLOCATE (WS_IN,DS_IN,SSI_IN,TSI_IN,calyear) -! IF(KSOLAR < 2) THEN -!**** Read in monthly-mean data -! DO I=1,iMs0X -! READ(NRFU,'(2I6,3F17.6)') IYEAR,IMONTH,TSI1(I),TSI2(I) -! READ(NRFU,'(5E14.6)') FSLEAN ! 1:190 -! SFNORM = TSI1(I) / SUM(FSLEAN(:)*DSLEAN(:)) -! UVLEAN(I,:)=FSLEAN(:)*SFNORM -! END DO -! ELSE -!**** Read in annual-mean data -! DO I=1,iMs0X -! IF(KSOLAR.ne.9) THEN -! READ(NRFU,'(F12.1,2F15.4)',end=908) yr2S0,TSI1(I),TSI2(I) -! ELSE -! READ(NRFU,'(I6,2F17.6)',end=908) yr2S0i,TSI1(I),TSI2(I) -! yr2S0=real(yr2S0i)+0.5 -! END IF -! if(I==1) yr1S0 = yr2S0 -! IF(KSOLAR.ne.9) THEN -! READ(NRFU,'(5E14.6)') FSLEAN ! 1:190 -! SFNORM=TSI1(I) / SUM(FSLEAN(:)*DSLEAN(:)) -! UVLEAN(I,:)=FSLEAN(:)*SFNORM -! ELSE ! ksolar=9 -! READ(NRFU,'(5E14.6)') (UVLEAN(I,K),K=1,190) -! ENDIF -! END DO - IF ( AM_I_ROOT() ) WRITE (6,*) 'read S0-history: ', yr1S0, & - &' - ', yr2S0 - ENDIF -! END IF - - -!----------------------------------------------------------------------- -!R(C) Read: Elaine Mathews 10 Fractional Vegetation Distributions -! 10 global maps (72x46) depict fractional vegetation/soil types -! Map-1 (bright sand) + Map-10 (black dirt) define desert albedo -! (sum of Maps 1-10 over land-area (ILON,JLAT) grid boxes = 1.0) -! -! Map-11 refers to plankton concentrations over ocean areas that -! are yet to be implemented. -! -------------------------------------------------------------- - - - - - -!----------------------------------------------------------------------- -!R(D) Read: 1 FOCEAN 72x46 ocean fraction (FOCEAN = 0 or 1) -! 2 FLAKE 72x46 lake fraction -! 3 FGRND 72x46 lake fraction -! 4 FGICE 72x46 glacial ice fraction -! (FLAKE + FGRND + FGICE + FOCEAN = 1.000) -! -! 5 ZATMO 72x46 topography (ocean = 0.0) -! 6 HOCEAN 72x46 ocean depth -! 7 HLAKE 72x46 lake depth -! 8 HGICE 72x46 glice depth -! 9 ZSOLID 72x46 topography of solid ground surface -! ----------------------------------------------------- -! -! FOLGIZ is for off-line use only, and is not used in GCM radiation. -! GCM supplies dynamically changing POCEAN,POICE,PEARTH,PLICE values -! ------------------------------------------------------------------ - - - - - 949 IFIRST = 0 - ENDIF - - -! --------------------------------------------------------------- -! LASTVC Initialize: Default Atmospheric Layering, Structure -! (for Off-Line use) as Specified by LASTVC Parameter -! If LASTVC < 0, GCM defines all Radiation Model Input -! otherwise: -! Each LASTVC digit(6) specifies a model configuration -! e.g.: LASTVC= 123456 -! L=0,1,..9 Layers NL= Any,GCM12,GCM23,Pset,Hset,etc -! A=0,1,..6 Atmosphere Any,Trop,MLS,MLW,SAS,SAW,Std -! S=0,1,..9 Surf Types POCEAN=1,PEARTH=1,POICE=1,etc -! T=0,1,..9 Tracer Aer Tau=0, Tau=0.1 Aer Comp(1-9) -! V=0,1,..9 Vegetation Sand,Tundra,Grass,Shrubs, etc -! C=0,1,..9 Cloud,R=10 Clim Cloud Tau in Layer(1,-9) -! ---------------------------------------------------- - - IF ( LASTVC>=0 ) CALL SETATM - -! ------------------------------------------------------- -! Set Solar Constant for Default Reference Time: Jan 1950 -! Default used for KSOLAR(=1) is that specified in RADPAR -! ------------------------------------------------------- - - JJDAYS = 1 - JYEARS = 1950 - IF ( KJDAYS>0 ) JJDAYS = KJDAYS - IF ( KYEARS>0 ) JYEARS = KYEARS -!---------------------------------------------- - CALL SETSOL(JYEARS,JJDAYS) -!---------------------------------------------- - - -! ------------------------------------------------------- -! Set Default Greenhouse Gas Reference Year to: Mid 1980 -! Default used for KTREND(=1) is that specified in RADPAR -! ------------------------------------------------------- - - JJDAYG = 184 - JYEARG = 1980 -!---------------------------------------------- - CALL SETGHG(JYEARG,JJDAYG) -!---------------------------------------------- - IF ( KJDAYG>0 ) JJDAYG = KJDAYG - IF ( KYEARG>0 ) JYEARG = KYEARG -!---------------------------------------------- - CALL UPDGHG(JYEARG,JJDAYG) -!---------------------------------------------- - -!-------------------------------- - CALL SETGAS -! - CALL SETBAK - IF ( MADAER>0 .OR. NTRACE>0 ) CALL SETAER - ! SETDST ops deferred to first call to GETDST once dust info known - !IF(MADDST > 0) CALL SETDST -!-------------------------------- - - -! ----------------------------------------------------- -! Set Volcanic Aerosol Effective Variance Default Value -! Particle Size(REFF0=0.3) when not known from data -! (VEFF0=0.35 is value based on thermal ISAMS data) -! ------------------------------------------------- - -!---------------------------------------------- - IF ( MADVOL>0 ) CALL SETVOL -!---------------------------------------------- - -!-------------------------------- - CALL SETCLD - -!-------------------------------- - - CALL SOLAR0 - 3000 FORMAT (A80) - 3001 FORMAT (18X,6(F7.5,1X)) - 3002 FORMAT (18X,6(F7.5,1X)/18X,6(F7.5,1X)) - 3003 FORMAT (18X,6(F7.3,1X)/18X,5(F7.3,1X)) - 3004 FORMAT (14X,7(F7.5,1X),4(/14X,7(F7.5,1X))) - 3005 FORMAT (/14X,7(F7.5,1X),4(/14X,7(F7.5,1X))) - 3007 FORMAT (18X,6(F7.3,1X)/18X,6(F7.3,1X)/18X,6(F7.3,1X)) - 3008 FORMAT (18X,5(F7.5,1X),4(/18X,5(F7.5,1X))) - 3009 FORMAT (18X,12(F3.1,1X)/18X,12(F3.1,1X)/18X,F3.0) - 3010 FORMAT (18X,12(F3.1,1X)/18X,12(F3.1,1X)/18X,F3.1) - 3012 FORMAT (18X,12(F3.1,1X)/18X,8(F3.1,1X)) - 3013 FORMAT (18X,5(F7.3,1X),4(/18X,5(F7.3,1X))) - - END SUBROUTINE RCOMP1 - - SUBROUTINE RCOMPT - USE SURF_ALBEDO, ONLY:UPDSUR - USE AERPARAM_MOD, ONLY:UPDATEAEROSOL, UPDATEAEROSOL2 - USE DUSTPARAM_MOD, ONLY:UPDDST2 - USE O3MOD, ONLY:UPDO3D, UPDO3D_SOLAR, plbo3, nlo3 -#ifdef HIGH_FREQUENCY_O3_INPUT - USE O3MOD, ONLY:UPDO3D_HIGHFREQUENCY -#endif - IMPLICIT NONE -!----------------------------------------------------------------------- -! -! Time Trend Selection Parameters and Options: -! ------------------------------------------- -! -! The Nominal Default Values are KYEARX = 0, and KJDAYX = 0, -! in which case RADPAR supplied Time JYEAR and JDAY are used -! -! When Non-Zero Values are specified for KYEARX and KJDAYX, -! the JYEAR,JDAY Time Dependence of the Specified Process is -! over-ridden by the Non-Zero KYEARX and KJDAYX Value. -! ---------------------------------------------------------- -! Process KYEARX KJDAYX -! KYEARS,KJDAYS SolarCon, UV 0 0 -! KYEARG,KJDAYG GH Gas Trend 0 0 -! KYEARO,KJDAYO Ozone Distr 0 0 -! KYEARA,KJDAYA AerClimtolgy 0 0 -! KYEARD,KJDAYD Desert Dust 0 0 -! KYEARV,KJDAYV Volcanic Aer 0 0 -! KYEARE,KJDAYE Epsilon Clds 0 0 -! KYEARR,KJDAYR Refl Surface 0 0 - -! ------------------------------------------------------------------ -! MADVEL Model Add-on Data of Extended Climatology Enable Parameter -! Each MADVEL digit is ON/OFF switch for corresponding input -! e.g. MADVEL=123456 (zero digit skips input process) -! -! MADAER = 2 Updates Aerosol 50y tropospheric climatology RFILE5 -! MADDST = 3 Updates Dust-windblown mineral climatology RFILE6 -! MADVOL = 4 Updates Volcanic 1950-00 aerosol climatology RFILE7 -! MADEPS = 5 Updates Epsilon cloud heterogeneity data RFILE8 -! MADLUV = 6 Updates Lean format Spectral Solar Irrad. RFILE9 -! -! Related Model Add-on Data Parameters set in RADPAR -! -! MADGHG = 1 Default Enables UPDGHG update. (MADGHG=0),no update -! MADSUR = 1 V72X46N.1.cor Vegetation type data RFILEC -! Z72X46N Ocean fraction, topography RFILED -! ------------------------------------------------------------------ - INTEGER JJDAYS, JYEARS, JJDAYG, JYEARG, JJDAYO, JYEARO, JJDAYA, & - JYEARA, JJDAYD, JYEARD, JJDAYV, JYEARV, JJDAYE, JYEARE, & - JJDAYR, JYEARR - -! ------------------------------------------------- -! Set Seasonal and Time (JDAY) Dependent Quantities -! ------------------------------------------------- - - JJDAYS = JDAY - JYEARS = JYEAR - IF ( KJDAYS>0 ) JJDAYS = KJDAYS - IF ( KYEARS>0 ) JYEARS = KYEARS -!---------------------------------------------- - IF ( MADLUV>0 ) CALL UPDSOL(JYEARS,JJDAYS) -!---------------------------------------------- - - JJDAYG = JDAY - JYEARG = JYEAR - IF ( KJDAYG>0 ) JJDAYG = KJDAYG - IF ( KYEARG>0 ) JYEARG = KYEARG -!---------------------------------------------- - IF ( MADGHG>0 ) CALL UPDGHG(JYEARG,JJDAYG) -!---------------------------------------------- - - JJDAYO = JDAY - JYEARO = JYEAR - IF ( KJDAYO/=0 ) JJDAYO = KJDAYO - IF ( KYEARO/=0 ) JYEARO = KYEARO -!---------------------------------------------- - CALL UPDO3D(JYEARO,JJDAYO,O3JDAY,O3JREF) -#ifdef HIGH_FREQUENCY_O3_INPUT - CALL UPDO3D_HIGHFREQUENCY(JYEARO,JJDAYO,O3JDAY_HF_modelLevels) -#endif - CALL UPDO3D_SOLAR(JJDAYO,S00WM2*RATLS0,O3JDAY) -!---------------------------------------------- - - JJDAYA = JDAY - JYEARA = JYEAR - IF ( KJDAYA>0 ) JJDAYA = KJDAYA - IF ( KYEARA/=0 ) JYEARA = KYEARA -!---------------------------------------------- - IF ( MADAER==3 ) THEN - CALL UPDATEAEROSOL2(JYEARA,JJDAYA,a6jday,plbaer) - ELSEIF ( MADAER/=0 ) THEN - CALL UPDATEAEROSOL(JYEARA,JJDAYA,a6jday,plbaer) - ENDIF -!---------------------------------------------- - - JJDAYD = JDAY - JYEARD = JYEAR - IF ( KJDAYD>0 ) JJDAYD = KJDAYD - IF ( KYEARD/=0 ) JYEARD = KYEARD -!---------------------------------------------- - IF ( MADDST>0 ) CALL UPDDST2(JYEARD,JJDAYD) -!---------------------------------------------- - - JJDAYV = JDAY - JYEARV = JYEAR - IF ( KJDAYV>0 ) JJDAYV = KJDAYV - IF ( KYEARV/=0 ) JYEARV = KYEARV -!---------------------------------------------- - IF ( MADVOL>0 ) CALL UPDVOL(JYEARV,JJDAYV) -!---------------------------------------------- - - JJDAYE = JDAY - JYEARE = JYEAR - IF ( KJDAYE>0 ) JJDAYE = KJDAYE - IF ( KYEARE>0 ) JYEARE = KYEARE -!---------------------------------------------- - IF ( MADEPS>0 ) CALL UPDEPS(JYEARE,JJDAYE) -!---------------------------------------------- - - JJDAYR = JDAY - JYEARR = JYEAR - IF ( KJDAYR>0 ) JJDAYR = KJDAYR - IF ( KYEARR>0 ) JYEARR = KYEARR -!---------------------------------------------- - CALL UPDSUR(JYEARR,JJDAYR) -!---------------------------------------------- - - END SUBROUTINE RCOMPT - - SUBROUTINE RCOMPX - USE SURF_ALBEDO, ONLY:GETSUR - USE O3MOD, ONLY:plbo3, nlo3, plbo3_traditional, NLO3_TRADITIONAL -#ifdef GCAP - USE O3MOD, ONLY:save_to3 -#endif -#ifdef SCM - USE SCM_COM, ONLY:SCMopt, SCMin -#endif - IMPLICIT NONE - INTEGER k -! ------------------------------------------------------------------ -! MADVEL Model Add-on Data of Extended Climatology Enable Parameter -! Each MADVEL digit is ON/OFF switch for corresponding input -! e.g. MADVEL=123456 (zero digit skips process) -! -! MADO3M = 1 Makiko 1951-1997 Ozone climatology RFILEA -! MADAER = 2 Updates Aerosol 50y tropospheric climatology RFILE5 -! MADDST = 3 Updates Dust-windblown mineral climatology RFILE6 -! MADVOL = 4 Updates Volcanic 1950-00 aerosol climatology RFILE7 -! MADEPS = 5 Epsilon cloud heterogeneity data RFILE8 -! MADLUV = 6 Lean format Spectral Solar Irrad. RFILE9 -! -! Related Model Add-on Data Parameters set in RADPAR -! -! MADGHG = 1 Default Enables UPDGHG update. (MADGHG=0),no update -! MADSUR = 1 V72X46N.1.cor Vegetation type data RFILEC -! Z72X46N Ocean fraction, topography RFILED -! ------------------------------------------------------------------ -! -! ----------------------------------------------------------------- -! Get Surface, Atmosphere, Sun Angle, Radiative Forcing, etc. Input -! to compute Solar/Thermal Radiation for given (JLAT,ILON) Grid-box -! -! The Radiation Model utilizes Data with 72x46 (lon,lat) resolution -! for GCM resolution other than 72x46, set JLAT and ILON -! to appropriately Sample (rather than interpolate) the -! 72x46 aerosol, ozone, cloud heterogeneity data sets -! -! The Radiation Model can accommodate arbitrary vertical resolution -! ----------------------------------------------------------------- - - -!-------------------------------- - IF ( set_gases_internally ) THEN -!!! CALL GETO3D(ILON,JLAT) ! may have to be changed ?? - IF ( use_o3_ref>0 ) THEN - ! in - CALL REPART(O3JREF(1,IGCM,JGCM),PLBO3_traditional, & - NLO3_TRADITIONAL+1,U0GAS(1,3),PLB0,NL+1) - ! out, ok if L1>1 ? - ! next block may seem weird but it is here to allow RCOMPX calls with - ! reference ozone in part of the atmosphere and tracer below: - IF ( use_tracer_chem(1)>0 ) U0GAS(1:use_tracer_chem(1),3) & - = chem_IN(1,1:use_tracer_chem(1)) - FULGAS(3) = 1.D0 - ELSE - ! in - CALL REPART(O3JDAY(1,IGCM,JGCM),PLBO3,NLO3+1,U0GAS(1,3), & - PLB0,NL+1) ! out, ok if L1>1 ? -#ifdef HIGH_FREQUENCY_O3_INPUT - ! Overwrite the lm_gcm levels with higher frequency ozone, leaving - ! climatology above those levels: - U0GAS(1:LM_GCM,3) = O3JDAY_HF_modelLevels(1:LM_GCM,IGCM, & - JGCM) - FULGAS(3) = 1.D0 -#endif -#ifdef SCM - IF ( SCMopt%OZONE ) THEN - ! Overwrite specified SCM levels (indicated by non-zero values), - ! leaving climatology above those levels: - DO k = 1, LM_GCM - IF ( SCMin%O3(k)>0. ) U0GAS(k,3) = SCMin%O3(k) - ENDDO - FULGAS(3) = 1.D0 - ENDIF -#endif - ! considering this move to here from setgas: - ! chem_out(:,1)=U0GAS(:,3)*FULGAS(3) ! save climatology O3 for chem - ! and might then need something like: - ! IF(KPFOZO==1)chem_out(1:NL0,1)=chem_out(1:NL0,1)*FPXOZO(1:NL0) - IF ( use_tracer_chem(1)>0 ) THEN - U0GAS(1:use_tracer_chem(1),3) & - = chem_IN(1,1:use_tracer_chem(1)) - FULGAS(3) = 1.D0 - ENDIF - ENDIF - CALL GETGAS - ELSE - CALL TAUGAS - ENDIF -!-------------------------------- - -#ifdef GCAP - ! Save DU of ozone used in calculation - save_to3(igcm,jgcm) = SUM(u0gas(:,3))*1000.0 -#endif - -!-------------------------------- - IF ( set_aerosols_internally ) THEN - SRBEXT = 1.D-20 - SRBSCT = 0. - SRBGCB = 0. - TRBALK = 0. - IF ( MADBAK>0 ) CALL GETBAK - - IF ( MADAER/=0 .OR. NTRACE>0 ) THEN - CALL GETAER - ELSE - SRAEXT = 0. - SRASCT = 0. - SRAGCB = 0. - TRAALK = 0. - ENDIF - IF ( MADDST>0 ) THEN - CALL GETDST - ELSE - SRDEXT = 0. - SRDSCT = 0. - SRDGCB = 0. - TRDALK = 0. - ENDIF - IF ( MADVOL>0 ) THEN - CALL GETVOL - ELSE - SRVEXT = 0. - SRVSCT = 0. - SRVGCB = 0. - TRVALK = 0. - ENDIF - chem_out(:,2) = SRVEXT(:,6) - ! save 3D aerosol extinction in SUB RADIA - ENDIF -!-------------------------------- - - -!-------------------------------- (GETSUR sets albedo needed by GETCLD) - CALL GETSUR(snoage_fac_max,MLAT46,JNORTH,KEEPAL,KSIALB,KZSNOW, & - MADSUR,COSZ,PLANCK,PLANCK_TMIN,PLANCK_TMAX,ILON,JLAT, & - AGESN,POCEAN,POICE,PEARTH,PLICE,PLAKE,zlake,TGO,TGOI, & - TGE,TGLI,ZOICE,FMP,ZSNWOI,zmp,SNOWOI,SNOWD,SNOWLI, & - SNOW_FRAC,WEARTH,WMAG,PVT,dalbsn,flags,LOC_CHL,BXA, & - PRNB,PRNX,SRBALB,SRXALB,TRGALB,BGFEMD,BGFEMT,DTRUFG, & - FTRUFG) - CALL GETEPS - CALL GETCLD -!-------------------------------- - -!-------------------------------- - CALL THERML - - CALL SOLARM -!-------------------------------- - END SUBROUTINE RCOMPX - - - SUBROUTINE UPDSOL(JYEARS,JJDAYS) - INTEGER, INTENT(IN) :: JYEARS, JJDAYS - CALL SETSOL(JYEARS,JJDAYS,1) - END SUBROUTINE UPDSOL - - SUBROUTINE SETSOL(JYEARS,JJDAYS,UPDSOL_flag) - IMPLICIT NONE -!----------------------------------------------------------------------- -! -! SETSOL Parameters: -!---------------------- -! KSOLAR Selects Solar Spectrum, (Lean vs Thekaekara Flux) -! JYEARS JYEAR Proxy: Sets: Solar Constant Reference Year -! JJDAYS JDAY Proxy: Sets Reference Year Month JDAY/30.5 -! (Nominal Reference: JYEARS= 1950 JJDAYS= January) -! -!----------------------------------------------------------------------- -! KSOLAR SOLSPEC UVWAVLs UVFACTs KUVFAC -!----------------------------------------------------------------------- -! -1 THEK Can be set Can be set (if KUVFAC=1) -!----------------------------------------------------------------------- -! 0 SSI Can be set Can be set (if KUVFAC=1) -!----------------------------------------------------------------------- -! 1 SSI Can be set Can be set (if KUVFAC=1) -!----------------------------------------------------------------------- -! -! (Option to Modify Solar UV Fluxes) -! UVWAVL Specified Edges of UV Flux Variation SubIntervals -! UVFACT Factors to Change the Amplitude of UV Variability -! -! KUVFAC ON/OFF switch for activating UV Flux Modification -! KSNORM Re-Normalize S0 (VIS) (after UV Amplitude Change) -! (Nominal UVWAVLs are: 0.295,0.310,0.366) -! -!----------------------------------------------------------------------- -! SETSOL Output: -!------------------ -! -! AO3 = Ozone Absorption Table AO3(460) -! (Solar UV Flux Weighted Absorption Table is used by the -! FUNCTION AO3ABS(OCM) in SOLAR to compute Ozone Heating) -! AO3 is the fraction of total Solar Flux absorbed by O3. -! -! S00WM2 = Solar Constant Reference Value for Time = JYEARS,JJDAYS -! (Thekaekara, if KSOLAR=-1, Reference = 1367 WATTS/M**2) -! -! -! SETSOL is Generally Called once at Model Initialization to Select -! Solar Flux (SSI,THEK), and to Define S00WM2 (RATLS0=1) -! -!----------------------------------------------------------------------- -! NOTE: -!----- -! S00WM2 = Nominal Reference Solar Constant 1366.448785D0 WATTS/M**2 -! (Spectral Integral: Lean99 Solar Flux for January 1950) -! -! KSOLAR=-1 Reproduces Thekaekhara Ozone Absorption, e.g., XRAD83XX -! KSOLAR= 0 Uses Lean99 Solar Flux as set for Time= (JYEARS,JJDAYS) -! KSOLAR= 1 Sets Lean99 Solar Flux to Current Time= (JYEARS,JJDAYS) -! KSOLAR= 2 same as 1 but based on annual (not monthly) data -! (JJDAYS used to select the specified Monthly-Mean Flux) -! KSOLAR= 9 annual data for current time from file, but Thekaekhara -! wavelength bins -! -!----------------------------------------------------------------------- -! -! UPDSOL Parameters: -!---------------------- -! JYEARS JYEAR Proxy: Selects Solar Constant Current Year -! JJDAYS JDAY Proxy: Selects Lean Data Month JJDAYS/30.5 -! -! UPDSOL Output: -!------------------ -! -! AO3 = Ozone Absorption Table AO3(460) -! (Solar UV Flux Weighted Absorption Table is used by the -! FUNCTION AO3ABS(OCM) in SOLAR to compute Ozone Heating) -! AO3 is the fraction of total Solar Flux absorbed by O3. -! -! RATLS0 = Ratio: Current-Time Solar Constant to Reference S00WM2 -! -!----------------------------------------------------------------------- -! Remark: -! -! UPDSOL is Called in RCOMPT to Update Solar Constant and Ozone AO3 -! Solar UV Absorption Dependence. (Monthly-Mean Data are -! NOT Interpolated in Time, but get Updated with Changing -! Month, i.e., whenever JDAY/30.5 Reaches Integer Value.) -! -!----------------------------------------------------------------------- - REAL*8, PARAMETER :: CORFAC = 1366.2911D0/1366.4487855D0 - INTEGER, INTENT(IN) :: JYEARS, JJDAYS - INTEGER, INTENT(IN), OPTIONAL :: UPDSOL_flag - INTEGER, SAVE :: LMOREF = 0 - INTEGER JMO, LMO, Is0x, K, I, NWSUV, II, J, NUV, icyc - REAL*8 FLXSUM, FFLUX(3), UVNORM, XX, OCM, TAUK, UVWAVA, UVWAVB, & - AO33 - - IF ( PRESENT(UPDSOL_flag) ) THEN - -!-------------------------------- -! ENTRY UPDSOL(JYEARS,JJDAYS) -!-------------------------------- - - IF ( KSOLAR<1 ) RETURN - ! solar constant not time dependent - IF ( JYEARS<1 ) RETURN - ! solar constant not time dependent - - IF ( jyears>2000 ) THEN - icyc = ICYCS0F - ELSE - icyc = ICYCS0 - ENDIF - IF ( Ksolar==1 ) THEN - ! monthly data - icyc = icyc*12 - JMO = 1 + JJDAYS/30.5D0 - IF ( JMO>12 ) JMO = 12 - LMO = (JYEARS-IY1S0)*12 + JMO - IF ( LMO>iMs0X ) LMO = LMO - icyc*((LMO-iMs0X+icyc-1)/icyc) - IF ( LMO<1 ) LMO = LMO + icyc*((icyc-lmo)/icyc) - ELSE ! annual data ksolar=2,9 - Is0x = NINT(yr2s0-yr1s0+1) - lmo = NINT(jyears-yr1s0+1.5) - IF ( LMO>Is0X ) LMO = LMO - icyc*((LMO-Is0X+icyc-1)/icyc) - IF ( LMO<1 ) LMO = LMO + icyc*((icyc-lmo)/icyc) - ENDIF - - IF ( LMO==LMOREF ) RETURN - ! solar constant up-to-date - LMOREF = LMO - -! Select Lean99 Solar Flux -! ------------------------ - IF ( KSOLAR/=9 ) THEN - FLXSUM = SUM(UV_SSI(LMO,1:190)*DS_SSI(1:190)) - ELSE - FLXSUM = TSI2(LMO) - ENDIF -! write(6,*) 'UPDSOLAR::FLXSUM::',FLXSUM - - IF ( KSOLAR/=9 ) THEN - I = 0 - DO K = 1, 50 - I = I + 1 - WSOLAR(I) = W1_SSI(K) - FSOLAR(I) = UV_SSI(LMO,K) - I = I + 1 - WSOLAR(I) = W1_SSI(K+1) - FSOLAR(I) = FSOLAR(I-1) - ENDDO - NWSUV = 100 - ELSE -! Select Thekaekhara Solar Flux -! ----------------------------- - WSOLAR(1:190) = WTHEK(1:190) - FSOLAR(1:190) = UV_SSI(LMO,1:190) - NWSUV = 190 - ENDIF -! Option to Modify Solar UV Flux -! ------------------------------ - IF ( KUVFAC==1 ) THEN - FFLUX(:) = 0.D0 - NUV = 1 - DO I = 1, NWSUV, 2 ! by twos to account for histogram - DO WHILE ( WSOLAR(I+1)>UVWAVL(NUV) ) - NUV = NUV + 1 - IF ( NUV>3 ) GOTO 20 - ENDDO - FFLUX(NUV) = FFLUX(NUV) + FSOLAR(I) & - *(WSOLAR(I+1)-WSOLAR(I)) - FSOLAR(I:I+1) = FSOLAR(I:I+1)*UVFACT(NUV) - ENDDO - 20 UVNORM = SUM(FFLUX(:)*(1D0-UVFACT(:))) - IF ( MADLUV==0 ) UVNORM = UVNORM*CORFAC - IF ( KSNORM==0 ) FLXSUM = FLXSUM - UVNORM - ENDIF - - RATLS0 = FLXSUM/S00WM2 - - DO I = 1, 460 - II = (I-10)/90 - 4 - XX = I - ((I-10)/90)*90 - OCM = XX*10.D0**II - DO J = 1, 226 - TAUK = FUVKO3(J)*OCM - IF ( TAUK>35.D0 ) TAUK = 35.D0 - UVA(J) = 1.D0 - EXP(-TAUK) - ENDDO - UVWAVA = 0.100D0 - UVWAVB = 0.400D0 - CALL FXGINT(UVA,XWAVO3,226,FSOLAR,WSOLAR,NWSUV,UVWAVA, & - UVWAVB,AO33) - AO3(I) = AO33/FLXSUM - ENDDO - GOTO 99999 - ELSE - -! Thekaekhara Solar Flux Option -! ----------------------------- - IF ( KSOLAR<0 ) THEN - WSOLAR(1:190) = WTHEK(1:190) - FSOLAR(1:190) = FTHEK(1:190) - S00WM2 = 1367.D0 - LMOREF = -111 - NWSUV = 190 - GOTO 130 - ENDIF -! Lean99 Solar Flux, UV Option -! ---------------------------- - IF ( jyears>2000 ) THEN - icyc = ICYCS0F - ELSE - icyc = ICYCS0 - ENDIF - IF ( Ksolar<2 ) THEN - ! monthly data - icyc = icyc*12 - JMO = 1 + JJDAYS/30.5D0 - IF ( JMO>12 ) JMO = 12 - LMO = (JYEARS-IY1S0)*12 + JMO - IF ( LMO>iMs0X ) LMO = LMO - icyc*((LMO-iMs0X+icyc-1)/icyc) - IF ( LMO<1 ) LMO = LMO + icyc*((icyc-lmo)/icyc) - ELSE ! annual data - Is0x = NINT(yr2s0-yr1s0+1) - lmo = NINT(jyears-yr1s0+1.5) - IF ( LMO>Is0X ) LMO = LMO - icyc*((LMO-Is0X+icyc-1)/icyc) - IF ( LMO<1 ) LMO = LMO + icyc*((icyc-lmo)/icyc) - ENDIF - LMOREF = LMO - -! IF(MADLUV==0) Default Option is then in force -! Default (FR_SSI) = Lean 1950 Jan Solar, UV flux -! CORFAC accounts for DS_SSI units in BLOCK DATA, -! and TSI1/TSI2 normalization of Lean input data. -! ----------------------------------------------- - -! CORFAC=1366.2911D0/1366.4487855D0 - IF ( KSOLAR/=9 ) THEN - IF ( MADLUV==0 ) S00WM2 = SUM(FR_SSI(:)*DS_SSI(:)*CORFAC) - IF ( MADLUV>0 ) S00WM2 = SUM(UV_SSI(LMO,:)*DS_SSI(:)) - ELSE - S00WM2 = TSI2(LMO) - ENDIF - - IF ( KSOLAR/=9 ) THEN - I = 0 - DO K = 1, 50 - I = I + 1 - WSOLAR(I) = W1_SSI(K) - IF ( MADLUV==0 ) FSOLAR(I) = FR_SSI(K) - IF ( MADLUV>0 ) FSOLAR(I) = UV_SSI(LMO,K) - I = I + 1 - WSOLAR(I) = W1_SSI(K+1) - FSOLAR(I) = FSOLAR(I-1) - ENDDO - NWSUV = 100 - ELSE - IF ( MADLUV==0 ) & - CALL STOP_MODEL("invalid MADLUV for KSOLAR=9",255) - WSOLAR(1:190) = WTHEK(1:190) - FSOLAR(1:190) = UV_SSI(LMO,1:190) - NWSUV = 190 - ENDIF - ENDIF - -! Option to Modify Solar UV Flux -! ------------------------------ - 130 IF ( KUVFAC==1 ) THEN - FFLUX(:) = 0.D0 - NUV = 1 - DO I = 1, NWSUV, 2 ! by twos to account for histogram - DO WHILE ( WSOLAR(I+1)>UVWAVL(NUV) ) - NUV = NUV + 1 - IF ( NUV>3 ) GOTO 50 - ENDDO - FFLUX(NUV) = FFLUX(NUV) + FSOLAR(I)*(WSOLAR(I+1)-WSOLAR(I)) - FSOLAR(I:I+1) = FSOLAR(I:I+1)*UVFACT(NUV) - ENDDO - 50 UVNORM = SUM(FFLUX(:)*(1D0-UVFACT(:))) - IF ( MADLUV==0 ) UVNORM = UVNORM*CORFAC - IF ( KSNORM==0 ) S00WM2 = S00WM2 - UVNORM - ENDIF -! ----------------------------------------------------- -! When KUVFAC=1 option multiplicative factors UVFACT(I) -! are used to change the UV spectral flux distribution, -! KSNORM=1 provides the option to keep S00WM2 constant. -! ----------------------------------------------------- - - RATLS0 = 1.D0 - - DO I = 1, 460 - II = (I-10)/90 - 4 - XX = I - ((I-10)/90)*90 - OCM = XX*10.D0**II - DO J = 1, 226 - TAUK = FUVKO3(J)*OCM - IF ( TAUK>35.D0 ) TAUK = 35.D0 - UVA(J) = 1.D0 - EXP(-TAUK) - ENDDO - UVWAVA = 0.100D0 - UVWAVB = 0.400D0 - CALL FXGINT(UVA,XWAVO3,226,FSOLAR,WSOLAR,NWSUV,UVWAVA,UVWAVB, & - AO33) - AO3(I) = AO33/S00WM2 - ENDDO - -! ------------------------------------------------ -! NOTE: AO3 is the Ozone-path Absorption Function -! AO3 convolves O3 asborption with solar UV -! spectral variations by FXGINT integration -! AO3 is expressed as the absorbed fraction -! of the total solar flux (S00WM2=1366W/m2) -! ----------------------------------------- - - RETURN - -99999 END SUBROUTINE SETSOL - - - SUBROUTINE SETGHG(JYEARG,JJDAYG) - IMPLICIT NONE -! -! -! --------------------------------------------------------------- -! SETGHG Sets Default Greenhouse Gas Reference Year (for FULGAS) -! -! Control Parameter: -! KTREND (specified in RADPAR) activates GH Trend -! Default -! KTREND = 1 -! Selects GTREND -! --------------------------------------------------------------- - INTEGER, INTENT(IN) :: JYEARG, JJDAYG - REAL*8 TREF - INTEGER I -! - TREF = JYEARG + (JJDAYG-0.999D0)/366.D0 -! - IF ( KTREND==0 ) THEN - XREF(1) = PPMV80(2) - XREF(2) = PPMV80(6) - XREF(3) = PPMV80(7) - XREF(4) = PPMV80(8)*1000.D0 - XREF(5) = PPMV80(9)*1000.D0 - XREF(6) = PPMV80(11)*1000.D0 - ! YREF11=PPMV80(11)*1000.D0 - XREF(7) = PPMV80(12)*1000.D0 - ! ZREF12=PPMV80(12)*1000.D0 - RETURN - ENDIF - - CALL GTREND(XREF,TREF) ! finds xref 1-6 (yref11=xx6=xref(6)) - XREF(7) = 1.D-13 ! ZREF12=1.D-13 - DO I = 1, NGHG - IF ( XREF(I)<1.D-06 ) XREF(I) = 1.D-06 - ENDDO - PPMV80(2) = XREF(1) - PPMV80(6) = XREF(2) - PPMV80(7) = XREF(3) - PPMV80(8) = XREF(4)/1000.D0 - PPMV80(9) = XREF(5)/1000.D0 - PPMV80(11) = XREF(6)/1000.D0 ! YREF11/1000.D0 - PPMV80(12) = XREF(7)/1000.D0 ! ZREF12/1000.D0 - END SUBROUTINE SETGHG -! -!-------------------------------- -! ENTRY UPDGHG(JYEARG,JJDAYG) -!-------------------------------- - SUBROUTINE UPDGHG(JYEARG,JJDAYG) - IMPLICIT NONE - INTEGER, INTENT(IN) :: JYEARG, JJDAYG - REAL*8 TNOW -! - TNOW = JYEARG + (JJDAYG-0.999D0)/366.D0 -! - IF ( KTREND==0 ) THEN - FULGAS(2) = PPMVK0(2)/XREF(1) - FULGAS(6) = PPMVK0(6)/XREF(2) - FULGAS(7) = PPMVK0(7)/XREF(3) - FULGAS(8) = PPMVK0(8)/XREF(4) - FULGAS(9) = PPMVK0(9)/XREF(5) - FULGAS(11) = PPMVK0(11)/XREF(6) - ! YREF11 - FULGAS(12) = PPMVK0(12)/XREF(7) - ! .../ZREF12 - RETURN - ENDIF - - CALL GTREND(XNOW,TNOW) ! finds xnow 1-6 (ynow11=xx6=xnow(6)) - XNOW(7) = 1.D-20 ! ZNOW12=1.D-20 - FULGAS(2) = XNOW(1)/XREF(1) - FULGAS(6) = XNOW(2)/XREF(2) - FULGAS(7) = XNOW(3)/XREF(3) - FULGAS(8) = XNOW(4)/XREF(4) - FULGAS(9) = XNOW(5)/XREF(5) - FULGAS(11) = XNOW(6)/XREF(6) - ! YNOW11/YREF11 - FULGAS(12) = XNOW(7)/XREF(7) - ! ZNOW12/ZREF12 -! - END SUBROUTINE UPDGHG - - SUBROUTINE GETGAS - CALL SETGAS(1) - END SUBROUTINE GETGAS - - SUBROUTINE SETGAS(GETGAS_flag) - IMPLICIT NONE -!----------------------------------------------------------------------- -! Global U.S. (1976) Standard Atmosphere P, T, Geo Ht Parameters -!----------------------------------------------------------------------- - INTEGER, OPTIONAL :: GETGAS_flag - REAL*8, PARAMETER :: P0 = 1013.25D0, PI = 3.141592653589793D0 - REAL*8, SAVE :: SINLAT(46) - INTEGER, SAVE :: IFIRST = 1, NL0 - INTEGER NLAY, NATM, L, J, K, N - REAL*8 RHP, EST, FWB, FWT, PLT, DP, EQ, ES, ACM, HI, FI, HL, HJ, & - FJ, DH, FF, GGVDF, ZT, ZB, EXPZT, EXPZB, PARTTR, PARTTG, & - PTRO, DL, DLS, DLN, Z0LAT, ULGASL, UGAS0(LX), UGASR(LX) - - IF ( PRESENT(GETGAS_flag) ) THEN - - -!----------------- -! ENTRY GETGAS -!----------------- -! --------------------------------------------- -! Specify ULGAS: Get Gas Absorption from TAUGAS -! --------------------------------------------- - -! ----------------------------------------------------- -! N20,CH4,F11,F12 Specified Latitudinal Z0 Distribution -! ----------------------------------------------------- - - IF ( KLATZ0>0 ) THEN - PTRO = 100.D0 - DL = DLAT46(JLAT) - DLS = -40.D0 - DLN = 40.D0 - IF ( DLDLN ) PTRO = 189.D0 + (DL-40.D0)*2.22D0 - DO L = 1, NL0 - IF ( PLB0(L)>=PTRO ) Z0LAT = HLB0(L) - ! orig. hlb not hlb0 - ENDDO - DO K = 6, 12 - IF ( K/=10 ) THEN - DO L = 1, NL0 - U0GAS(L,K) = PPMV80(K) & - *PPMV_TO_CM_AT_STP*(PLB0(L)-PLB0(L+1)) - IF ( PLB0(1)>=PTRO ) THEN - ! safety check until P,H hard-coding removed - ZT = (HLB0(L+1)-Z0LAT)/ZH(K) - ! orig. hlb not hlb0 - IF ( ZT>0.D0 ) THEN - ZB = (HLB0(L)-Z0LAT)/ZH(K) - ! orig. hlb not hlb0 - EXPZT = EXP(-ZT) - EXPZB = EXP(-ZB) - IF ( ZB<0.D0 ) EXPZB = 1.D0 - ZB - U0GAS(L,K) = U0GAS(L,K)*(EXPZB-EXPZT) & - /MAX(ZT-ZB,1D-6) - ENDIF - ENDIF ! safety check - ENDDO - ENDIF - ENDDO - ENDIF - - DO L = L1, NL - DPL(L) = PLB(L) - PLB(L+1) - PL(L) = (PLB(L)+PLB(L+1))*0.5D0 - ENDDO - - IF ( KEEPRH/=2 ) THEN ! keep RH,SH - IF ( KEEPRH==1 ) THEN ! find SH from RH - DO L = L1, NL - ES = 10.D0**(9.4051D0-2353.D0/TLM(L)) - SHL(L) = 0.622D0*(RHL(L)*ES) & - /(PL(L)-0.378D0*(RHL(L)*ES)) - ENDDO - ELSE - DO L = L1, NL ! find RH from SH - EQ = PL(L)*SHL(L)/(0.662D0+0.378D0*SHL(L)) - ES = 10.D0**(9.4051D0-2353.D0/TLM(L)) - RHL(L) = EQ/ES - ENDDO - ENDIF - ENDIF - - U0GAS(L1:NL,1) = H2O_MMR_TO_CM_AT_STP*DPL(L1:NL)*SHL(L1:NL) & - /(1-SHL(L1:NL)) -!c*** Adjust water vapor in ALL layers -!c ULGAS(L1:NL,1)=U0GAS(L1:NL,1)*FULGAS(1) -!**** Only adjust stratospheric levels (above LS1_loc) - ULGAS(L1:LS1_loc-1,1) = U0GAS(L1:LS1_loc-1,1) - ULGAS(LS1_loc:NL,1) = U0GAS(LS1_loc:NL,1)*FULGAS(1) -!**** - ULGAS(1:NL0,3) = U0GAS(1:NL0,3)*FULGAS(3) - IF ( KPFOZO==1 ) ULGAS(1:NL0,3) = ULGAS(1:NL0,3)*FPXOZO(1:NL0) - - DO L = L1, NL0 ! =L1,NL for GCM use, =1,NL0 for offline use - PARTTR = (PLB(L)-PLB(L+1))/(PLB0(L)-PLB0(L+1)) - DO K = 2, 12 - IF ( K/=3 ) THEN - PARTTG = PARTTR - IF ( KPGRAD>0 ) & - PARTTG = PARTTG*(1.D0+0.5D0*PPGRAD(K)*SINLAT & - (JLAT)) - ULGAS(L,K) = U0GAS(L,K)*FULGAS(K)*PARTTG - ENDIF - ENDDO - ULGAS(L,13) = U0GAS(L,13)*FULGAS(13) - ENDDO - - chem_out(:,4) = ULGAS(:,7) - ! climatological CH4 saved for chemistry - IF ( use_tracer_chem(2)>0 ) ULGAS(1:use_tracer_chem(2),7) & - = chem_IN(2,1:use_tracer_chem(2)) - ! allow use of tracer CH4. -#ifdef GCC_COUPLE_RAD - GCCco2_out(:) = ULGAS(:,2) - IF ( use_tracer_GCCco2>0 ) THEN - ULGAS(1:use_tracer_GCCco2,2) & - = GCCco2_IN(1:use_tracer_GCCco2) - ULGAS(use_tracer_GCCco2+1:NL,2) & - = GCCco2_IN(use_tracer_GCCco2) - ENDIF -#endif - - IF ( MRELAY>0 ) THEN ! for offline use only - IF ( NO3COL>0 ) ULGAS(1:NL0,3) = U0GAS(1:NL0,3) & - *RO3COL/SUM(U0GAS(1:NL0,3)) - ! rescale ozone to col.amount RO3COL - DO K = 2, 12 ! repartition to new layering - IF ( K/=10 .OR. KEEP10<=0 ) THEN - UGAS0(1:NL0) = ULGAS(1:NL0,K) - CALL REPART(UGAS0,PLB0,NL0+1,UGASR,PLB,NL+1) - ULGAS(1:NL,K) = UGASR(1:NL) - ENDIF - ENDDO - IF ( KEEP10>0 .AND. KEEP10<10 ) ULGAS(1:NL,KEEP10) & - = ULGAS(1:NL,10) - IF ( KEEP10>10 ) ULGAS(1:NL,KEEP10-10) & - = ULGAS(1:NL,KEEP10-10) + ULGAS(L,10) - ENDIF - - IF ( NL>40 ) THEN - IF ( kfpco2>=3 ) CALL GET_FPXCO2_105(FPXCO2(NL-38:NL),jlat, & - MLAT46,jday) - ENDIF - ULGAS(1:NL0,2) = ULGAS(1:NL0,2)*FPXCO2(1:NL0) - - chem_out(:,1) = ULGAS(:,3) - !O3 considering move to RCOMPX; see above -! chem_out(:,2)= _________ ! set in RCOMPX - chem_out(:,3) = ULGAS(:,6) ! N2O -! chem_out(:,4)=ULGAS(:,7) ! CH4 (moved above before tracer option) - chem_out(:,5) = ULGAS(:,8) + ULGAS(:,9) - ! CFC11(+) + CFC12(+) - ! output CO2 in mole CO2 per mole air: - CO2outCol(1:NL) = 1.D-6*ULGAS(1:NL,2) & - /(PPMV_TO_CM_AT_STP*DPL(1:NL)) - -!----------------- - CALL TAUGAS - ELSE - - IF ( IFIRST==1 ) THEN - SINLAT(:) = SIN(DLAT46(:)*PI/180.D0) - NL0 = NL - IFIRST = 0 - ENDIF -! ----------------------------------------------------- -! Use PLB to fix Standard Heights for Gas Distributions -! ----------------------------------------------------- - -!nu PS0=PLB0(1) - - DO L = 1, NL0 - DPL(L) = PLB0(L) - PLB0(L+1) - PL(L) = (PLB0(L)+PLB0(L+1))*0.5D0 -!nu HLB(L)=HLB0(L) - ENDDO -!nu HLB(NL0+1)=HLB0(NL0+1) -!cc CALL RETERP(UFAC36,P36,36,FPXCO2,PL,NL0) - CALL SET_FPXCO2(PL,FPXCO2,NL0,KFPCO2) -!c IUFAC=1 -!c IF(IUFAC==0) FPXCO2(:)=1 - - NLAY = LASTVC/100000 - NATM = (LASTVC-NLAY*100000)/10000 - IF ( NATM<=0 ) THEN - -! ---------------------------------------------------------------- -! Define Default Global Mean Gas Amounts for Off-Line Use Purposes -! -! IGAS=1 Global Mean H2O Distribution -! ---------------------------- - RHP = 0.77D0 - EST = 10.D0**(9.4051D0-2353.D0/TLB(1)) - FWB = 0.662D0*RHP*EST/(PLB0(1)-RHP*EST) - DO L = 1, NL0 - PLT = PLB0(L+1) - DP = PLB0(L) - PLT - RHP = 0.77D0*(PLT/P0-0.02D0)/.98D0 - EST = 10.D0**(9.4051D0-2353.D0/TLT(L)) - FWT = 0.662D0*RHP*EST/(PLT-RHP*EST) - IF ( FWT<=3.D-06 ) THEN - FWT = 3.D-06 - RHP = FWT*PLT/(EST*(FWT+0.662D0)) - ENDIF - ULGASL = 0.5D0*(FWB+FWT)*DP*H2O_MMR_TO_CM_AT_STP - U0GAS(L,1) = ULGASL - SHL(L) = ULGASL/(ULGASL+H2O_MMR_TO_CM_AT_STP*DP) - EQ = 0.5D0*(PLB0(L)+PLT)*SHL(L)/(0.662D0+0.378D0*SHL(L)) - ES = 10.D0**(9.4051D0-2353.D0/TLM(L)) - RHL(L) = EQ/ES - FWB = FWT - ENDDO - ENDIF - -! ---------------------------- -! IGAS=5 Global Mean NO2 Distribution -! ---------------------------- - ACM = 0.D0 - HI = 0.D0 - FI = CMANO2(1) - HL = HLB0(2) - L = 1 - J = 1 - DO - J = J + 1 - IF ( J>42 ) EXIT - HJ = HI + 2.D0 - FJ = CMANO2(J) - DO - DH = HJ - HI - IF ( HJ>HL ) THEN - FF = FI + (FJ-FI)*(HL-HI)/DH - DH = HL - HI - ACM = ACM + (FI+FJ)*DH*0.5D0 - U0GAS(L,5) = ACM - ACM = 0.D0 - HI = HL - FI = FF - IF ( L==NL0 ) GOTO 133 - L = L + 1 - HL = HLB0(L+1) - ELSE - ACM = ACM + (FI+FJ)*DH*0.5D0 - HI = HJ - FI = FJ - EXIT - ENDIF - ENDDO - ENDDO - 133 DO - U0GAS(L,5) = ACM - ACM = 0.D0 - L = L + 1 - IF ( L>=NL0+1 ) THEN -! ----------------------------------------- -! IGAS=2 and 4 (CO2,O2) Uniformly Mixed Gas Distribution -! ----------------------------------------- - DO K = 2, 4, 2 - U0GAS(1:NL0,K) = PPMV80(K) & - *PPMV_TO_CM_AT_STP*DPL(1:NL0) - ENDDO -! ----------------------------------------------------- -! IGAS=6-12 (N20,CH4,F11,F12) Specified Vertical Gas Distribution -! ----------------------------------------------------- - DO K = 6, 12 - IF ( K/=10 ) THEN - DO N = 1, NL0 - GGVDF = 1.D0 - (1.D0-PPMVDF(K)) & - *(1.D0-PLB0(N)/PLB0(1)) - IF ( KGGVDF<1 ) GGVDF = 1.D0 - U0GAS(N,K) = PPMV80(K)*PPMV_TO_CM_AT_STP*DPL(N) & - *GGVDF - ZT = (HLB0(N+1)-Z0(K))/ZH(K) - IF ( ZT>0.D0 ) THEN - ZB = (HLB0(N)-Z0(K))/ZH(K) - EXPZT = EXP(-ZT) - EXPZB = EXP(-ZB) - IF ( ZB<0.D0 ) EXPZB = 1.D0 - ZB - U0GAS(N,K) = U0GAS(N,K)*(EXPZB-EXPZT) & - /MAX(ZT-ZB,1D-6) - ENDIF - ENDDO - ENDIF - ENDDO -! -------------------------------------------- -! Specification of FULGAS Scaled Gas Amounts -! -------------------------------------------- - -!c*** Adjust water vapor in ALL layers ! IGAS=1 -!c ULGAS(1:NL0,1)=U0GAS(1:NL0,1)*FULGAS(1) -!**** Only adjust stratospheric levels (above LS1_loc) - ULGAS(1:LS1_loc-1,1) = U0GAS(1:LS1_loc-1,1) - ULGAS(LS1_loc:NL0,1) = U0GAS(LS1_loc:NL0,1)*FULGAS(1) -!**** - ULGAS(1:NL0,3) = U0GAS(1:NL0,3)*FULGAS(3) ! IGAS=3 - IF ( KPFOZO==1 ) ULGAS(1:NL0,3) = ULGAS(1:NL0,3) & - *FPXOZO(1:NL0) - - DO L = 1, NL0 ! IGAS=2,4-13 -!!! PARTTR = (PLB(L)-PLB(L+1)) / (PLB0(L)-PLB0(L+1)) ! PLB=PLB0 ?? - DO K = 2, 12 -!!! PARTTG=PARTTR ! next line not possible at this point (jlat=???) -!!! IF(KPGRAD > 0) PARTTG=PARTTG*(1.D0+0.5D0*PPGRAD(K)*SINLAT(JLAT)) - IF ( K/=3 ) ULGAS(L,K) = U0GAS(L,K)*FULGAS(K) - !!! *PARTTG - ENDDO - ENDDO - ULGAS(1:NL0,13) = U0GAS(1:NL0,13)*FULGAS(13) - - ULGAS(1:NL0,2) = ULGAS(1:NL0,2)*FPXCO2(1:NL0) - - RETURN - ENDIF - ENDDO - ENDIF -!----------------- - - END SUBROUTINE SETGAS - - - SUBROUTINE GETO2A - CALL SETO2A(1) - END SUBROUTINE GETO2A - - SUBROUTINE SETO2A(GETO2A_flag) - IMPLICIT NONE - INTEGER, OPTIONAL :: GETO2A_flag - - INTEGER, PARAMETER :: NW = 18, NZ = 11, NKO2 = 6 - - REAL*8, PARAMETER :: SFWM2(NW) & - = (/2.196E-3,0.817E-3,1.163E-3,1.331E-3, & - 1.735E-3,1.310E-3,1.311E-3,2.584E-3, & - 2.864E-3,4.162E-3,5.044E-3,6.922E-3, & - 6.906E-3,10.454E-3,5.710E-3,6.910E-3, & - 14.130E-3,18.080E-3/), SIGMA(NW,NKO2) & - = RESHAPE & - ((/2.74E-19,2.74E-19,2.74E-19,2.74E-19, & - 2.74E-19,2.74E-19,4.33E-21,4.89E-21, & - 6.63E-21,1.60E-20,7.20E-20,1.59E-18, & - 2.10E-21,2.32E-21,3.02E-21,6.30E-21, & - 3.46E-20,7.52E-19,5.95E-22,9.72E-22, & - 2.53E-21,7.57E-21,7.38E-20,7.44E-19, & - 3.33E-22,1.02E-22,4.09E-21,1.63E-20, & - 8.79E-20,3.81E-19,1.09E-21,1.16E-21, & - 1.45E-21,3.32E-21,2.00E-20,4.04E-19, & - 1.15E-21,1.30E-21,1.90E-21,4.89E-21, & - 2.62E-20,4.08E-19,3.90E-22,4.90E-22, & - 9.49E-22,3.33E-21,2.14E-20,2.39E-19, & - 1.29E-22,2.18E-22,8.28E-22,3.46E-21, & - 1.94E-20,1.06E-19,6.26E-23,7.80E-23, & - 2.62E-22,1.83E-21,1.25E-20,3.95E-20, & - 2.74E-23,3.58E-23,8.64E-23,4.03E-22, & - 2.13E-21,1.95E-20,1.95E-23,2.44E-23, & - 4.89E-23,2.87E-22,1.95E-21,1.36E-20, & - 1.84E-23,1.96E-23,2.71E-23,8.52E-23, & - 6.48E-22,3.89E-21,1.80E-23,1.81E-23, & - 1.87E-23,2.69E-23,1.34E-22,1.52E-21, & - 1.80E-23,1.80E-23,1.82E-23,2.40E-23, & - 5.71E-23,5.70E-22,1.76E-23,1.76E-23, & - 1.76E-23,1.76E-23,1.76E-23,3.50E-23, & - 1.71E-23,1.71E-23,1.71E-23,1.71E-23, & - 1.71E-23,2.68E-23,1.00E-23,1.00E-23, & - 1.00E-23,1.00E-23,1.00E-23,1.00E-23/), & - (/NW,NKO2/)), WTKO2(NKO2) & - = (/0.05,0.20,0.25,0.25,0.20,0.05/), & - STPMOL = 2.68714D+19 - - REAL*8, SAVE :: ZTABLE(LX+1,11) - INTEGER, SAVE :: NL0 - INTEGER, SAVE :: IFIRST = 1 - REAL*8 FSUM, SUMMOL, ZCOS, WSUM, TAU, DLFLUX, WTI, WTJ - INTEGER I, J, K, L, JI, JJ, N - - IF ( PRESENT(GETO2A_flag) ) THEN - -!----------------- -! ENTRY GETO2A -!----------------- - -! --------------------------------------------------------- -! UV absorption by Oxygen is expressed as a fraction of the -! total solar flux S0. Hence, O2FHRL(L)=ZTABLE(L,J) must be -! normalized within SOLARM, dividing the GETO2A absorptions -! O2FHRL(L) and O2FHRB(L) by the fraction of the solar flux -! within the spectral interval DKS0(15), nominally by 0.05. -! --------------------------------------------------------- - ! offline: may not yet work properly if NL>NL0 - ZCOS = 1.D0 + 10.D0*COSZ - JI = ZCOS - IF ( JI>10 ) JI = 10 - JJ = JI + 1 - WTJ = ZCOS - JI - WTI = 1.0 - WTJ - O2FHRL(L1:NL) = WTI*ZTABLE(L1:NL,JI) + WTJ*ZTABLE(L1:NL,JJ) - O2FHRB(L1:NL) = ZTABLE(L1:NL,6) - GOTO 99999 - ENDIF - - IF ( mado2a==0 ) THEN - ZTABLE(:,:) = 0. - RETURN - ENDIF - - IF ( IFIRST==1 ) THEN - NL0 = NL - DO N = 1, NL0 - ULGAS(N,4) = PPMV80(4)*PPMV_TO_CM_AT_STP*(PLB0(N)-PLB0(N+1)) - ENDDO - IFIRST = 0 - ENDIF - - FSUM = SUM(SFWM2(:)) - ZTABLE(NL0+1,:) = FSUM - - SUMMOL = 0.D0 - DO L = NL0, 1, -1 - SUMMOL = SUMMOL + ULGAS(L,4)*STPMOL - DO J = 1, NZ - ZCOS = 0.01D0*(1/J) + 0.1D0*(J-1) - FSUM = 0.D0 - DO I = 1, NW - WSUM = 0.D0 - DO K = 1, NKO2 - TAU = SIGMA(I,K)*SUMMOL/ZCOS - IF ( TAU>30 ) TAU = 30 - WSUM = WSUM + WTKO2(K)*EXP(-TAU) - ENDDO - FSUM = FSUM + WSUM*SFWM2(I) - ENDDO - ZTABLE(L,J) = FSUM - ENDDO - ENDDO - DO J = 1, NZ - DO L = 1, NL0 - DLFLUX = ZTABLE(L+1,J) - ZTABLE(L,J) - ZTABLE(L,J) = DLFLUX/1366.D0 - ENDDO - ENDDO - - RETURN - -99999 END SUBROUTINE SETO2A - - - SUBROUTINE GETBAK - CALL SETBAK(1) - END SUBROUTINE GETBAK - - SUBROUTINE SETBAK(GETBAK_flag) - IMPLICIT NONE - INTEGER, OPTIONAL :: GETBAK_flag -! ------------------------------------------------------------------ -! SETBAK,GETBAK Initializes Background Aerosol Specification, i.e., -! Aerosol Composition and Distribution that is set in -! RADPAR by AGOLDH, BGOLDH, CGOLDH Factors -! and controlled by FGOLDH ON/OFF Scaling Parameters. -! Optional tracers may be added in SETAER/GETAER -! ------------------------------------------------------------------ -! Tau Scaling Factors: Solar Thermal apply to: -! FSTAER FTTAER ! Total Aerosol -! FSBAER FTBAER ! Bgrnd Aerosol -! -! Control Parameters/Aerosol Scaling (kill) Factors -! FSTAER SW (All-type) Aerosol Optical Depth -! FTTAER LW (All-type) Aerosol Optical Depth -! FSBAER SW SETBAKonly Aerosol Optical Depth -! FTBAER LW SETBAKonly Aerosol Optical Depth -! ----------------------------------------------- - - REAL*8, SAVE :: SRAX(LX,6,5), SRAS(LX,6,5), SRAC(LX,6,5) - INTEGER, SAVE :: IFIRST = 1 - INTEGER, SAVE :: NL0 = 0 - - REAL*8 SGOLDH(5), TGOLDH(5), C, BC, ABC, HXPB, HXPT, ABCD - INTEGER I, J, K, L - - IF ( PRESENT(GETBAK_flag) ) THEN - -!----------------- -! ENTRY GETBAK -!----------------- -! ------------------------------------------------------------------ -! GETBAK Specifies Background Aerosol Contribution and Initializes -! (1) Thermal Radiation Aerosol Coefficient Table: -! TRAALK(L,K), for (L=1,NL), (K=1,33) -! -! (2) Solar Radiation Coefficient Tables: -! SRAEXT(L,K),SRASCT(L,K),SRAGCB(L,K) for (K=1,6) -! --------------------------------------------------- -! Warning: MRELAY-section missing: not ready if NL.ne.NL0 -! (Thermal) -! --------- - TGOLDH(:) = FTTAER*FTBAER*FGOLDH(:) ! 1:5 - DO K = 1, 33 - DO L = L1, NL0 - TRBALK(L,K) = SUM(TGOLDH(:)*TRAX(L,K,:)) + 1.D-20 - ENDDO - ENDDO - -! (Solar) -! ------- - - SGOLDH(:) = FSTAER*FSBAER*FGOLDH(:) ! 1:5 - DO K = 1, 6 - DO L = L1, NL0 - SRBEXT(L,K) = SUM(SGOLDH(:)*SRAX(L,K,:)) + 1.D-20 - SRBSCT(L,K) = SUM(SGOLDH(:)*SRAS(L,K,:)) + 1.D-30 - SRBGCB(L,K) = SUM(SGOLDH(:)*SRAS(L,K,:)*SRAC(L,K,:)) & - /SRBSCT(L,K) - ENDDO - ENDDO - GOTO 99999 - ENDIF - -!**** Background aerosols -! ------------------------------------------------------------------ -! Thermal: Set (5) Aerosol Type Compositions Vertical Distribution -! ------------------------------------------------------------------ - IF ( IFIRST==1 ) THEN - NL0 = NL - IFIRST = 0 - ENDIF - - TRAX(:,:,:) = 0 ! 1:NL0,1:NKBAND,1:5 - - DO I = 1, 11 - DO J = 1, 5 - IF ( AGOLDH(I,J)>=1.D-06 ) THEN - C = CGOLDH(I,J) - BC = EXP(-BGOLDH(I,J)/C) - ABC = AGOLDH(I,J)*(1.D0+BC) - - HXPB = 1.D0 - DO L = 1, NL0 - HXPT = HLB0(L+1)/C ! orig. hlb not hlb0 - IF ( HXPT<=80.D0 ) THEN - HXPT = EXP(HXPT) - ABCD = ABC/(1.D0+BC*HXPB) - ABC/(1.D0+BC*HXPT) - HXPB = HXPT - TRAX(L,:,J) = TRAX(L,:,J) & - + ABCD*(TRAQEX(:,I)-TRAQSC(:,I)) - ! 1:NKBAND - ENDIF - ENDDO - ENDIF - ENDDO - TRAQAB(:,I) = TRAQEX(:,I) - TRAQSC(:,I) - ENDDO - - TRBALK(:,:) = 0 ! 1:NL0,1:NKBAND - -!----------------------------------------------------------------------- -! SOLAR: Set (5) Aerosol Type Compositions Vertical Distribution -!----------------------------------------------------------------------- - - SRAX(:,:,:) = 1.D-20 ! 1:NL0,1:6,1:5 - SRAS(:,:,:) = 1.D-30 - SRAC(:,:,:) = 0 - - DO I = 1, 11 - DO J = 1, 5 - IF ( AGOLDH(I,J)>=1.D-06 ) THEN - C = CGOLDH(I,J) - BC = EXP(-BGOLDH(I,J)/C) - ABC = AGOLDH(I,J)*(1.D0+BC) - - HXPB = 1.D0 - DO L = 1, NL0 - HXPT = HLB0(L+1)/C ! orig. hlb not hlb0 - IF ( HXPT<=80.D0 ) THEN - HXPT = EXP(HXPT) - ABCD = ABC/(1.D0+BC*HXPB) - ABC/(1.D0+BC*HXPT) - HXPB = HXPT - SRAX(L,:,J) = SRAX(L,:,J) + ABCD*SRAQEX(:,I) - SRAS(L,:,J) = SRAS(L,:,J) + ABCD*SRAQSC(:,I) - SRAC(L,:,J) = SRAC(L,:,J) + ABCD*SRAQCB(:,I) & - *SRAQSC(:,I) - ENDIF - ENDDO - ENDIF - ENDDO - ENDDO - - SRAC(:,:,:) = SRAC(:,:,:)/SRAS(:,:,:) ! 1:NL0,1:6,1:5 - - SRBEXT(:,:) = 1.D-20 ! 1:NL0,1:6 - SRBSCT(:,:) = 0 - SRBGCB(:,:) = 0 -!nu SRBPI0(:,:) = 0 - - RETURN - - -99999 END SUBROUTINE SETBAK - - - SUBROUTINE GETAER - CALL SETAER(1) - END SUBROUTINE GETAER - - SUBROUTINE SETAER(GETAER_flag) -!c INCLUDE 'rad00def.radCOMMON.f' -#if (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - USE RESOLUTION, ONLY:LM -#endif - USE AERPARAM_MOD, ONLY:DRYM2G - USE AERPARAM_MOD, ONLY:LMA - IMPLICIT NONE - INTEGER, OPTIONAL :: GETAER_flag -! --------------------------------------------------------------- -! GISS MONTHLY-MEAN (1850-2050) TROPOSPHERIC AEROSOL CLIMATOLOGY -! --------------------------------------------------------------- - -! Tau Scaling Factors: Solar Thermal apply to: -! FSTAER FTTAER ! Total Aerosol -! FSAAER FTAAER ! AClim Aerosol - -! Control Parameters/Aerosol Scaling (kill) Factors -! FSTAER SW (All-type) Aerosol Optical Depth -! FTTAER LW (All-type) Aerosol Optical Depth -! FSAAER SW AClim Aer Aerosol Optical Depth -! FTAAER LW AClim Aer Aerosol Optical Depth -! ----------------------------------------------- - -!nu DIMENSION ATAU09(9) -!c DIMENSION PLBA09(10) ! Aerosol data pressure levels -!c DATA PLBA09/1010.,934.,854.,720.,550.,390.,255.,150.,70.,10./ -! Crystallization RH Deliquescence RH - REAL*8, PARAMETER, DIMENSION(4) :: RHC = (/.38D0,.47D0,.28D0,.38D0 /), & - RHD = (/.80D0,.75D0,.62D0,.80D0 /) - -! ------------------------------------------------------------------ -! Define aerosol size according to REFDRY specification -! (if KRHAER(NA)=0, REFWET is used) -! FRSULF= Sulfate fraction of basic aerosol composition -! -! Set size SO4 (NA=1) = Sulfate aerosol (Nominal dry Reff=0.2) -! Set size SEA (NA=2) = SeaSalt aerosol (Nominal dry Reff=1.0) -! Set size ANT (NA=3) = Nitrate aerosol (Nominal dry Reff=0.3) -! Set size OCX (NA=4) = Organic aerosol (Nominal dry Reff=0.3) -! ------------------------------------------------------------------ - REAL*8 AREFF, XRH, FSXTAU, FTXTAU, SRAGQL, RHFTAU, q55, RHDNA, & - RHDTNA - REAL*8 ATAULX(LX,6), TTAULX(LX,ITRMAX), SRBGQL, FAC, RHFTAU_dry -#if (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - REAL*8, DIMENSION(LM,6) :: EXT, SCT, GCB - REAL*8, DIMENSION(LM,33) :: TAB -#endif - INTEGER NRHNAN(LX,8), K, L, NA, N, NRH, M, KDREAD, NT - - -#if (defined TRACERS_AMP) || (defined TRACERS_TOMAS) - IF ( skip_AOD_in_rad ) THEN - ! rad_interact_aer>0 -#ifdef TRACERS_AMP - CALL SETAMP(EXT,SCT,GCB,TAB) -#endif -#ifdef TRACERS_TOMAS - CALL SETTOMAS(EXT,SCT,GCB,TAB) -#endif -!radiation has 3 extra levels on the top - aerosols are zero -! SW - SRBEXT(L1:LM,:) = EXT(L1:LM,:) - SRBSCT(L1:LM,:) = SCT(L1:LM,:) - SRBGCB(L1:LM,:) = GCB(L1:LM,:) -! LW - TRBALK(L1:LM,:) = TAB(L1:LM,:) - - RETURN - ! nothing else to do here, everything handled in SETAMP/SETTOMAS - ENDIF -#endif - - IF ( PRESENT(GETAER_flag) ) THEN - - -!----------------- -! ENTRY GETAER -!----------------- - - NRHNAN(:,:) = 1 - DO L = L1, NL - IF ( RHL(L)>0.9005D0 ) THEN - XRH = (RHL(L)-0.899499D0)*1000.D0 - NRH = XRH + 90 - IF ( NRH>189 ) NRH = 189 - ELSE - XRH = RHL(L)*100.D0 + 0.5D0 - NRH = XRH - IF ( NRH<0 ) NRH = 0 - ENDIF - DO NA = 1, 4 - IF ( KDELIQ(L,NA)==0 ) THEN - RHDNA = RHD(NA) - IF ( KRHDTK==1 ) RHDNA = RHDTNA(TLM(L),NA) - IF ( RHL(L)>RHDNA ) KDELIQ(L,NA) = 1 - ELSE - IF ( RHL(L)0 ) THEN - - DO NA = 1, 6 - IF ( MADAER==3 ) THEN -#ifdef REPART_AER_FIX - ! passing plb0 instead of plb for approximate consistency with input - ! in - CALL REPART(A6JDAY(1,NA,IGCM,JGCM),PLBAER,lma+1, & - ATAULX(1,NA),PLB0,NL+1) ! out -#else - ! in - CALL REPART(A6JDAY(1,NA,IGCM,JGCM),PLBAER,lma+1, & - ATAULX(1,NA),PLB,NL+1) ! out -#endif - ELSE - ! in - CALL REPART(A6JDAY(1,NA,ILON,JLAT),PLBA09,10, & - ATAULX(1,NA),PLB,NL+1) ! out - ENDIF - ENDDO - - FSXTAU = FSTAER*FSAAER + 1.D-10 - FTXTAU = FTTAER*FTAAER - ! (Solar BCI,BCB components) - DO L = L1, NL - nintaerext(L,:,5) = SRBQEX(:,5)*ATAULX(L,5) & - *FSXTAU*FS8OPX(5) - nintaerext(L,:,6) = SRBQEX(:,6)*ATAULX(L,6) & - *FSXTAU*FS8OPX(6) - nintaersca(L,:,5) = SRBQSC(:,5)*ATAULX(L,5) & - *FSXTAU*FS8OPX(5) - nintaersca(L,:,6) = SRBQSC(:,6)*ATAULX(L,6) & - *FSXTAU*FS8OPX(6) - nintaerasy(L,:,5) = SRBQCB(:,5) - nintaerasy(L,:,6) = SRBQCB(:,6) - SRAEXT(L,:) = nintaerext(L,:,5) + nintaerext(L,:,6) - SRASCT(L,:) = nintaersca(L,:,5) + nintaersca(L,:,6) - SRAGCB(L,:) = (nintaersca(L,:,5)*nintaerasy(L,:,5)+ & - nintaersca(L,:,6)*nintaerasy(L,:,6)) & - /(SRASCT(L,:)+1.D-10) - ENDDO - ! (Thermal BCI,BCB components) - DO L = L1, NL - TRAALK(L,:) = TRBQAB(:,5)*ATAULX(L,5)*FTXTAU*FT8OPX(5) & - + TRBQAB(:,6)*ATAULX(L,6)*FTXTAU*FT8OPX(6) - ! 1:33 - IF ( PLB(L)<=10 ) TRAALK(L,:) = 0 - ENDDO - - DO NA = 1, 4 - DO L = L1, NL - RHFTAU = RHINFO(NRHNAN(L,NA),2,NA)*ATAULX(L,NA) & - *FSXTAU*FS8OPX(NA) - DO K = 1, 6 - nintaerext(L,K,NA) = SRHQEX(K,NRHNAN(L,NA),NA) & - *RHFTAU - nintaersca(L,K,NA) = SRHQSC(K,NRHNAN(L,NA),NA) & - *RHFTAU - nintaerasy(L,K,NA) = SRHQCB(K,NRHNAN(L,NA),NA) - SRAEXT(L,K) = SRAEXT(L,K) + nintaerext(L,K,NA) - SRAGQL = SRAGCB(L,K)*SRASCT(L,K) & - + nintaerasy(L,K,NA)*nintaersca(L,K,NA) - SRASCT(L,K) = SRASCT(L,K) + nintaersca(L,K,NA) - SRAGCB(L,K) = SRAGQL/(SRASCT(L,K)+1.D-10) - ENDDO - ENDDO - ENDDO - - DO NA = 1, 4 - DO L = L1, NL - RHFTAU = RHINFO(NRHNAN(L,NA),2,NA)*ATAULX(L,NA) & - *FTXTAU*FT8OPX(NA) - TRAALK(L,:) = TRAALK(L,:) + TRHQAB(:,NRHNAN(L,NA),NA) & - *RHFTAU ! 1:33 - ENDDO - ENDDO - ENDIF - - - IF ( NTRACE<=0 ) RETURN - -! ------------------------------------------------------------------ -! Option to add on Tracer Type aerosol thermal solar contributions -! -! NOTE: Aerosol carried as a tracer is assumed to be in kg/m2 units -! ------------------------------------------------------------------ - - DO NT = 1, NTRACE - IF ( ITR(NT)==7 ) THEN - FAC = 1D3*.75D0/TRADEN(NT)*RTINFO(1,9,NT)/TRRDRY(NT) - ELSE - FAC = 1D3*.75D0/DENAER(ITR(NT))*Q55DRY(ITR(NT)) & - /TRRDRY(NT) - ENDIF - TTAULX(L1:NL,NT) = TRACER(L1:NL,NT)*FAC - ENDDO - - FSXTAU = FSTAER*FSBAER + 1.D-10 - FTXTAU = FTTAER*FTBAER - - DO NT = 1, NTRACE - NA = ITR(NT) - DO L = L1, NL - RHFTAU = RTINFO(NRHNAN(L,NA),2,NT)*TTAULX(L,NT)*FSXTAU - RHFTAU_dry = RTINFO(1,2,NT)*TTAULX(L,NT)*FSXTAU - IF ( FSTOPX(NT)>0 ) THEN - RHFTAU = RHFTAU*FSTOPX(NT)*FSTASC(NT) - RHFTAU_dry = RHFTAU_dry*FSTOPX(NT)*FSTASC(NT) - DO K = 1, 6 - SRBEXT(L,K) = SRBEXT(L,K) & - + SRTQEX(K,NRHNAN(L,NA),NT)*RHFTAU - SRBGQL = SRBGCB(L,K)*SRBSCT(L,K) & - + SRTQCB(K,NRHNAN(L,NA),NT) & - *SRTQSC(K,NRHNAN(L,NA),NT)*RHFTAU - SRBSCT(L,K) = SRBSCT(L,K) & - + SRTQSC(K,NRHNAN(L,NA),NT)*RHFTAU - SRBGCB(L,K) = SRBGQL/(SRBSCT(L,K)+1.D-10) - ENDDO - ENDIF - aesqex(L,:,nt) = srtqex(:,nrhnan(L,na),nt)*rhftau - ! 1:6 - aesqsc(L,:,nt) = srtqsc(:,nrhnan(L,na),nt)*rhftau - aesqcb(L,:,nt) = srtqcb(:,nrhnan(L,na),nt)*aesqsc(L,:,nt) - aesqex_dry(L,:,nt) = srtqex(:,1,nt)*rhftau_dry - ! 1:6 - aesqsc_dry(L,:,nt) = srtqsc(:,1,nt)*rhftau_dry - aesqcb_dry(L,:,nt) = srtqcb(:,1,nt)*aesqsc_dry(L,:,nt) - ENDDO - ENDDO - - DO NT = 1, NTRACE - NA = ITR(NT) - DO L = L1, NL - RHFTAU = RTINFO(NRHNAN(L,NA),2,NT)*TTAULX(L,NT) & - *FTXTAU*FTTOPX(NT)*FTTASC(NT) - TRBALK(L,:) = TRBALK(L,:) + TRTQAB(:,NRHNAN(L,NA),NT) & - *RHFTAU ! 1:33 - ENDDO - ENDDO - ELSE - - IF ( MADAER>0 ) THEN - DO NA = 1, 4 - AREFF = REFDRY(NA) -!nu IF(KRHAER(NA) < 0) AREFF=REFWET(NA) - CALL GETMIE(NA,AREFF,SRHQEX(1,1,NA),SRHQSC(1,1,NA), & - SRHQCB(1,1,NA),TRHQAB(1,1,NA),Q55DRY(NA)) - DRYM2G(NA) = 0.75D0/DENAER(NA)*Q55DRY(NA)/AREFF -!nu IF(KRHAER(NA) < 0) DRYM2G(NA)=WETM2G(NA) - RHINFO(1,1,NA) = 0.D0 ! Rel Hum - RHINFO(1,2,NA) = 1.D0 ! TAUFAC - RHINFO(1,3,NA) = AREFF ! AerSize - RHINFO(1,4,NA) = 0.D0 ! LW g/m2 - RHINFO(1,5,NA) = 1.33333333D0*AREFF*DENAER(NA)/Q55DRY(NA) - ! Dryg/m2 - RHINFO(1,6,NA) = 1.33333333D0*AREFF*DENAER(NA)/Q55DRY(NA) - ! Totg/m2 - RHINFO(1,7,NA) = 1.D0 ! Xmas fr - RHINFO(1,8,NA) = DENAER(NA) ! Density - RHINFO(1,9,NA) = Q55DRY(NA) ! Q55 Ext - ENDDO - -! Set size BCI (NA=5) = Black Carbon (Industrial) (Nominal Reff=0.1) -! Set size BCB (NA=6) = Black Carbon (BioBurning) (Nominal Reff=0.1) -! ------------------------------------------------------------------ - DO NA = 5, 6 - AREFF = REFDRY(NA) - CALL GETMIE(NA,AREFF,SRBQEX(1,NA),SRBQSC(1,NA), & - SRBQCB(1,NA),TRBQAB(1,NA),Q55DRY(NA)) - DRYM2G(NA) = 0.75D0/DENAER(NA)*Q55DRY(NA)/AREFF - ENDDO - - ! Extend default dry aerosol coefficients for N=2,190 - DO N = 2, 190 - DO NA = 1, 4 - SRHQEX(:,N,NA) = SRHQEX(:,1,NA) - ! 1:6 - SRHQSC(:,N,NA) = SRHQSC(:,1,NA) - ! 1:6 - SRHQCB(:,N,NA) = SRHQCB(:,1,NA) - ! 1:6 - TRHQAB(:,N,NA) = TRHQAB(:,1,NA) - ! 1:33 - RHINFO(N,1:9,NA) = RHINFO(1,1:9,NA) - ENDDO - ENDDO - ! Over-write dry coefficients if KRHAER(NA)=1 - KDREAD = 71 ! default unit number for offline use only - DO NA = 1, 4 -!nu IF(KRHAER(NA) > 0) THEN - CALL SETREL(REFDRY(NA),NA,kdread,SRUQEX,SRUQSC,SRUQCB, & - TRUQEX,TRUQSC,TRUQCB,REFU22,Q55U22,FRSULF, & - SRHQEX(1,1,NA),SRHQSC(1,1,NA),SRHQCB(1,1,NA),& - TRHQAB(1,1,NA),RHINFO(1,1,NA)) -!nu ENDIF - ENDDO - ENDIF - - IF ( NTRACE<=0 ) RETURN - -!**** Optional Tracer aerosols initializations - DO NT = 1, NTRACE - NA = ITR(NT) - AREFF = TRRDRY(NT) - CALL GETMIE(NA,AREFF,SRTQEX(1,1,NT),SRTQSC(1,1,NT), & - SRTQCB(1,1,NT),TRTQAB(1,1,NT),Q55) - RTINFO(1,1,NT) = 0.0 - RTINFO(1,2,NT) = 1.0 - RTINFO(1,3,NT) = AREFF - RTINFO(1,4,NT) = 0.0 - RTINFO(1,5,NT) = 1.33333333D0*AREFF*DENAER(NA)/Q55 - RTINFO(1,6,NT) = 1.33333333D0*AREFF*DENAER(NA)/Q55 - RTINFO(1,7,NT) = 1.0 - RTINFO(1,8,NT) = DENAER(NA) - RTINFO(1,9,NT) = Q55 - ENDDO - ! Define default dry aerosol coefficients for N=2,190 - DO N = 2, 190 - DO NT = 1, NTRACE - SRTQEX(:,N,NT) = SRTQEX(:,1,NT) - ! 1:6 - SRTQSC(:,N,NT) = SRTQSC(:,1,NT) - ! 1:6 - SRTQCB(:,N,NT) = SRTQCB(:,1,NT) - ! 1:6 - TRTQAB(:,N,NT) = TRTQAB(:,1,NT) - ! 1:33 - RTINFO(N,1:9,NT) = RTINFO(1,1:9,NT) - ENDDO - ENDDO - ! Over-write dry coefficients if KRHTRA(NT)=1 - KDREAD = 71 ! default unit number for offline use only - DO NT = 1, NTRACE - NA = ITR(NT) - IF ( KRHTRA(NT)>0 .AND. NA<=4 ) & - CALL SETREL(TRRDRY(NT),NA,KDREAD,SRUQEX,SRUQSC,SRUQCB, & - TRUQEX,TRUQSC,TRUQCB,REFU22,Q55U22,FRSULF, & - SRTQEX(1,1,NT),SRTQSC(1,1,NT),SRTQCB(1,1,NT), & - TRTQAB(1,1,NT),RTINFO(1,1,NT)) - ENDDO - - RETURN - ENDIF - - END SUBROUTINE SETAER - -!----------------- -! ENTRY GETDST -!----------------- - SUBROUTINE GETDST -! --------------------------------------------------------------- -! MONTHLY-MEAN DESERT DUST CLIMATOLOGY -! --------------------------------------------------------------- - -! OUTPUT: via SRDEXT(L,K) D Dust Extinction Optical Depth -! SRDSCT(L,K) D Dust Scattering Optical Depth -! SRDGCB(L,K) D Dust Asymmetry Parameter g -! TRDALK(L,K) Thermal Absorption Optical Depth - -! Tau Scaling Factors: Solar Thermal apply to: -! FSTAER FTTAER ! Total Aerosol -! FSDAER FTDAER ! Dust Aerosol -! -! Control Parameters/Aerosol Scaling (kill) Factors -! FSTAER SW (All-type) Aerosol Optical Depth -! FTTAER LW (All-type) Aerosol Optical Depth -! FSDAER SW Dust Aer Aerosol Optical Depth -! FTDAER LW Dust Aer Aerosol Optical Depth -! ----------------------------------------------- - USE DUSTPARAM_MOD - IMPLICIT NONE - REAL*8 FSXTAU, FTXTAU, DTAULX(LX+1,nsized) - !ron - INTEGER K, L, N - REAL*8 :: TDUST_col(lmd) - - IF ( .NOT.dust_optics_initialized ) THEN - dust_optics_initialized = .TRUE. - ALLOCATE (QXDUST(6,nsized),QSDUST(6,nsized),QCDUST(6,nsized), & - ATDUST(33,nsized),QDST55(nsized)) - - ALLOCATE (taucon_dust(nsized)) - DO N = 1, nsized - CALL GETMIE(7,REDUST(N),QXDUST(1,N),QSDUST(1,N),QCDUST(1,N),& - ATDUST(1,N),QDST55(N)) - ! save the factor for converting from concentration to AOT - TAUCON_dust(N) = 0.75E+03*QDST55(N)/(RODUST(N)*REDUST(N)) - ENDDO - ENDIF - - DO N = 1, nsized - TDUST_col(:) = DDJDAY(:,N,IGCM,JGCM)*taucon_dust(n) - ! kg/m2 -> tau -#ifdef REPART_AER_FIX - ! passing plb0 instead of plb for approximate consistency with input - CALL REPART(TDUST_col,PLBdust,lmd+1,DTAULX(1,N),PLB0,NL+1) -#else - CALL REPART(TDUST_col,PLBdust,lmd+1,DTAULX(1,N),PLB,NL+1) -#endif - ENDDO - -! Apply Solar/Thermal Optical Depth Scaling Factors -! Dust Aerosol Solar FSXD=FSTAER*FSDAER -! Dust Aerosol Thermal FTXD=FSTAER*FTDAER -! ---------------------------------------- - - FSXTAU = FSTAER*FSDAER + 1.D-10 - FTXTAU = FTTAER*FTDAER - - DO K = 1, 6 - DO L = L1, NL - SRDEXT(L,K) = 2.D-10 - SRDSCT(L,K) = 1.D-10 - SRDGCB(L,K) = 0.D0 - ENDDO - ENDDO - - DO L = L1, NL - DO K = 1, 6 - nintaerext(L,K,7) = SUM(QXDUST(K,:)*DTAULX(L,:)) & - *FSXTAU*FS8OPX(7) - nintaersca(L,K,7) = SUM(QSDUST(K,:)*DTAULX(L,:)) & - *FSXTAU*FS8OPX(7) - SRDEXT(L,K) = SRDEXT(L,K) + nintaerext(L,K,7) - SRDSCT(L,K) = SRDSCT(L,K) + nintaersca(L,K,7) - nintaerasy(L,K,7) = SUM(QCDUST(K,:)*QSDUST(K,:)*DTAULX(L,:))& - *FSXTAU*FS8OPX(7)/(SRDSCT(L,K)+1.D-10) - SRDGCB(L,K) = nintaerasy(L,K,7) - ENDDO - ENDDO - - DO L = L1, NL - DO K = 1, 33 - TRDALK(L,K) = SUM(ATDUST(K,:)*DTAULX(L,:)*FTXTAU*FT8OPX(7)) - ! 1:nsized !ron - ENDDO - ENDDO - - END SUBROUTINE GETDST - - - SUBROUTINE UPDVOL(JYEARV,JDAYVA) - INTEGER, INTENT(IN) :: JYEARV, JDAYVA - CALL SETVOL(JYEARV,JDAYVA) - END SUBROUTINE UPDVOL - - SUBROUTINE GETVOL - CALL SETVOL(GETVOL_FLAG=1) - END SUBROUTINE GETVOL - - SUBROUTINE SETVOL(JYEARV,JDAYVA,GETVOL_flag) - IMPLICIT NONE - - - REAL*8, SAVE :: E46LAT(47), SIZLAT(46), TAULAT(46) - INTEGER, SAVE :: NJ46 - REAL*8, PARAMETER :: HVOL00(5) = (/15.0,20.0,25.0,30.0,35.0/) -!x INTEGER, SAVE :: LATVOL = 0 ! not ok for grids finer than 72x46 - -!nu REAL*8, PARAMETER :: htplim=1.d-3 - REAL*8, SAVE :: FSXTAU, FTXTAU - INTEGER, INTENT(IN), OPTIONAL :: JYEARV, JDAYVA, GETVOL_flag - INTEGER J, L, MI, MJ, K - REAL*8 XYYEAR, XYI, WMI, WMJ, SIZVOL - !nu ,SUMHTF - REAL*8, SAVE, ALLOCATABLE :: gdata(:), hlattf(:), HTFLAT(:,:) - REAL*8, SAVE, ALLOCATABLE :: HTPROF(:) -#ifdef HEALY_LM_DIAGS - INTEGER, SAVE :: NJDG - REAL*8, SAVE :: EDGLAT(JM_DIAG) -#endif - -! ------------------------------------------------------------------ -! Tau Scaling Factors: Solar Thermal apply to: -! FSTAER FTTAER ! Total Aerosol -! FSVAER FTVAER ! SETVOL Aer - -! Control Parameters/Aerosol Scaling (kill) Factors -! FSTAER SW (All-type) Aerosol Optical Depth -! FTTAER LW (All-type) Aerosol Optical Depth -! FSVAER SW SETVOLonly Aerosol Optical Depth -! FTVAER LW SETVOLonly Aerosol Optical Depth -! ----------------------------------------------- - -! ----------------------------------------------------------------- -! VEFF0 Selects Size Distribution Variance (this affects Thermal) -! REFF0 Selects Effective Particle Size for Archive Volcanic Data -! ----------------------------------------------------------------- - - IF ( PRESENT(JYEARV) ) THEN ! UPDVOL - - -!-------------------------------- -! ENTRY UPDVOL(JYEARV,JDAYVA) -!-------------------------------- - -! (Volcanic data) -! ------------------------- - XYYEAR = JYEARV + JDAYVA/366.D0 - IF ( XYYEARNVOLMON-.001D0 ) XYI = NVOLMON - .001D0 -!! write(6,'(a,2f9.1,3i7)') 'VOLCYEAR=', -!! . XYI,XYYEAR,JVOLYI,JYEARV,JDAYVA - MI = XYI - WMJ = XYI - MI - WMI = 1.D0 - WMJ - MJ = MI + 1 - DO J = 1, NVolLat - GDATA(J) = WMI*VReffTJ(MI,J) + WMJ*VReffTJ(MJ,J) -!! write(6,'(a,2I7,2f8.1,2f10.4)')'VOLCREFF:: ',MI,MJ, -!! . XYYEAR,XYI,VReffTJ(MI,J),VReffTJ(MJ,J) - ENDDO - CALL RETERP(GDATA,ELATVol,NVolLat+1,SIZLAT,E46LAT,NJ46) - DO K = 1, NVOLK - DO J = 1, NVolLat - GDATA(J) = WMI*VTauTJK(MI,J,K) + WMJ*VTauTJK(MJ,J,K) -!! write(6,'(a,3I7,2f8.1,2F10.4)')'VOLCAER:: ',K,MI,MJ, -!! . XYYEAR,XYI,VTauTJK(MI,J,K),VTauTJK(MJ,J,K) - ENDDO - CALL RETERP(GDATA,ELATVOL,NVolLat+1,HTFLAT(1,K),E46LAT,NJ46) - ENDDO -! - -#ifdef HEALY_LM_DIAGS - DO J = 1, 46 - TAULAT(J) = SUM(HTFLAT(J,:)) - ENDDO - CALL RETERP(TAULAT,E46LAT,NJ46,VTAULAT,EDGLAT,NJDG) -#endif - - - RETURN - ELSEIF ( PRESENT(GETVOL_flag) ) THEN ! GETVOL - - -!----------------- -! ENTRY GETVOL -!----------------- -!x IF(MRELAY > 0) GO TO 300 -!x IF(JLAT==LATVOL) GO TO 350 ! not ok for grids finer than 72x46 - -! Set JLAT Dependent Aerosol Distribution and Size -! ------------------------------------------------ -!x300 CONTINUE - - HLATTF(1:NVolK) = HTFLAT(JLAT,1:NVolK) - CALL REPART(HLATTF,HVOLKM,NVolK+1,HTPROF,HLB0,NL+1) -!nu LHPMAX=0 ! not used -!nu LHPMIN=NL ! not used -!nu DO L=L1,NL -!nu N=NL+1-L -!nu IF(HTPROF(L) >= HTPLIM) LHPMAX=L -!nu IF(HTPROF(N) >= HTPLIM) LHPMIN=N -!nu END DO -!nu SUMHTF=1.D-10 - DO L = L1, NL - IF ( HTPROF(L)<0. ) HTPROF(L) = 0.D0 -!nu SUMHTF=SUMHTF+HTPROF(L) - ENDDO - - SIZVOL = SIZLAT(JLAT) - -! Select H2SO4 Q,S,C,A Tables for Size = SIZVOL -! ---------------------------------------------- - -!------------------------ - CALL GETQVA(SIZVOL) -!------------------------ - -!x LATVOL=JLAT -!x350 CONTINUE -! ------------------------------------ -! H2SO4 Thermal Contribution in TRVALK -! ------------------------------------ - DO K = 1, 33 - TRVALK(L1:NL,K) = HTPROF(L1:NL)*AVH2S(K)*FTXTAU*FT8OPX(8) - ENDDO - -! H2SO4 Solar Contribution in SRVEXT,SRVSCT,SRVGCB -! ------------------------------------------------ - - DO K = 1, 6 - nintaerext(L1:NL,K,8) = QVH2S(K)*HTPROF(L1:NL) & - *FSXTAU*FS8OPX(8) - nintaersca(L1:NL,K,8) = SVH2S(K)*HTPROF(L1:NL) & - *FSXTAU*PIVMAX*FS8OPX(8) - nintaerasy(L1:NL,K,8) = GVH2S(K) - SRVEXT(L1:NL,K) = nintaerext(L1:NL,K,8) - SRVSCT(L1:NL,K) = nintaersca(L1:NL,K,8) - SRVGCB(L1:NL,K) = nintaerasy(L1:NL,K,8) - ENDDO - GOTO 99999 - ENDIF - - FSXTAU = FSTAER*FSVAER - FTXTAU = FTTAER*FTVAER - -! Set Grid-Box Edge Latitudes for Data Repartitioning -! --------------------------------------------------- - IF ( madvol==1 ) THEN - ALLOCATE (ELATVOL(NVolLat+1)) - DO J = 2, 24 - ! NVolLat - ELATVOL(J) = -90.D0 + (J-1.5D0)*180.D0/23.D0 - ENDDO - ELATVol(1) = -90.D0 - ELATVol(25) = 90.D0 - HVolKM = HVOL00 - ENDIF - NJ46 = 46 + 1 - DO J = 2, 46 - E46LAT(J) = -90.D0 + (J-1.5D0)*180.D0/(MLAT46-1) - ENDDO - E46LAT(1) = -90.D0 - E46LAT(NJ46) = 90.D0 -#ifdef HEALY_LM_DIAGS - NJDG = JM_DIAG + 1 - DO J = 2, JM_DIAG - EDGLAT(J) = -90.D0 + (J-1.5D0)*180.D0/(JM_DIAG-1) - ENDDO - EDGLAT(1) = -90.D0 - EDGLAT(NJDG) = 90.D0 -#endif - ALLOCATE (gdata(NVolLat),hlattf(NVolK),HTFLAT(NJ46,NVOLK)) - ALLOCATE (HTPROF(NL)) - - HTPROF(:) = 0 - -! ----------------------------------------------- -! Initialize H2SO4 Q,S,C,A Tables for Input VEFF0 -! ----------------------------------------------- -! ------------------ - CALL SETQVA(VEFF0) -! ------------------ - - RETURN - -99999 END SUBROUTINE SETVOL - - - SUBROUTINE GETQVA(SIZVOL) - REAL*8, INTENT(IN) :: SIZVOL - CALL SETQVA(SIZVOL=SIZVOL) - END SUBROUTINE GETQVA - - SUBROUTINE SETQVA(VEFF,SIZVOL) - IMPLICIT NONE -! ------------------------------------------------------------------ -! SETQVA Selects (interpolates) H2SO4 Mie Parameters for specified -! Variance VEFF for subsequent Size interpolation by GETQVA -! ------------------------------------------------------------------ - -!eq REAL*8 SRQV( 6,20),SRSV( 6,20),SRGV( 6,20),Q55V( 20),REFV(20) -!eq REAL*8 TRQV(33,20),TRSV(33,20),TRGV(33,20),TRAV(33,20),VEFV(20) - REAL*8 TRAB(33,20), Q5(5), RV20(20), QV20(20) - REAL*8, PARAMETER :: V5(5) = (/.1D0,.2D0,.3D0,.4D0,.5D0/) - SAVE TRAB - -! ------------------------------------------------------------------ -! SRVQEX Volcanic Aerosol sizes (Reff) range from 0.1 to 5.0 microns -! To utilize equal interval interpolation, Reff N=9,20 are redefined -! so Volcanic Aerosol sizes have effective range of 0.1-2.0 microns. -! ------------------------------------------------------------------ - REAL*8, INTENT(IN), OPTIONAL :: SIZVOL, VEFF - REAL*8 REFN, RADX, WTJHI, WTJLO - INTEGER K, N, JRXLO, JRXHI - - IF ( PRESENT(SIZVOL) ) THEN - -!------------------------- -! ENTRY GETQVA(SIZVOL) -!------------------------- -! ------------------------------------------------------------------ -! Volcanic Aerosol sizes have effective range of 0.1 - 2.0 microns. -! ------------------------------------------------------------------ - - RADX = SIZVOL*10.D0 - IF ( RADX<1.000001D0 ) RADX = 1.000001D0 - IF ( RADX>19.99999D0 ) RADX = 19.99999D0 - JRXLO = RADX - WTJHI = RADX - JRXLO - WTJLO = 1.D0 - WTJHI - JRXHI = JRXLO + 1 - - QVH2S(:) = WTJLO*SRQV(:,JRXLO) + WTJHI*SRQV(:,JRXHI) - ! 1:6 - SVH2S(:) = WTJLO*SRSV(:,JRXLO) + WTJHI*SRSV(:,JRXHI) - GVH2S(:) = WTJLO*SRGV(:,JRXLO) + WTJHI*SRGV(:,JRXHI) - - Q55H2S = WTJLO*Q55V(JRXLO) + WTJHI*Q55V(JRXHI) - - AVH2S(:) = WTJLO*TRAB(:,JRXLO) + WTJHI*TRAB(:,JRXHI) - ! 1:33 - GOTO 99999 - ENDIF - - DO N = 1, 20 - RV20(N) = REFV20(N,1) - VEFV(N) = VEFF - REFV(N) = N/10.D0 - Q5(:) = Q55V20(N,:5) - CALL SPLINE(V5,Q5,5,VEFF,Q55V(N),1.D0,1.D0,1) - DO K = 1, 6 - Q5(:) = SRVQEX(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,SRQV(K,N),1.D0,1.D0,1) - Q5(:) = SRVQSC(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,SRSV(K,N),1.D0,1.D0,1) - Q5(:) = SRVQCB(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,SRGV(K,N),1.D0,1.D0,1) - ENDDO - DO K = 1, 33 - Q5(:) = TRVQEX(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,TRQV(K,N),1.D0,1.D0,1) - Q5(:) = TRVQSC(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,TRSV(K,N),1.D0,1.D0,1) - Q5(:) = TRVQCB(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,TRGV(K,N),1.D0,1.D0,1) - Q5(:) = TRVQAL(K,N,:5) - CALL SPLINE(V5,Q5,5,VEFF,TRAV(K,N),1.D0,1.D0,1) - ENDDO - TRAB(:,N) = TRQV(:,N) - TRSV(:,N) - ! 1:33 - ENDDO - - QV20(:) = Q55V(:) ! 1:20 - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,Q55V(N),1.D0,1.D0,1) - ENDDO - DO K = 1, 6 - QV20(:) = SRQV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,SRQV(K,N),1.D0,1.D0,1) - ENDDO - QV20(:) = SRSV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,SRSV(K,N),1.D0,1.D0,1) - ENDDO - QV20(:) = SRGV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,SRGV(K,N),1.D0,1.D0,1) - ENDDO - ENDDO - DO K = 1, 33 - QV20(:) = TRQV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,TRQV(K,N),1.D0,1.D0,1) - ENDDO - QV20(:) = TRSV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,TRSV(K,N),1.D0,1.D0,1) - ENDDO - QV20(:) = TRGV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,TRGV(K,N),1.D0,1.D0,1) - ENDDO - QV20(:) = TRAV(K,:) - DO N = 9, 20 - REFN = REFV(N) - CALL SPLINE(RV20,QV20,20,REFN,TRAV(K,N),1.D0,1.D0,1) - ENDDO - DO N = 9, 20 - TRAB(K,N) = TRQV(K,N) - TRSV(K,N) - ENDDO - ENDDO - - RETURN - -99999 END SUBROUTINE SETQVA - - SUBROUTINE SETCLD - IMPLICIT NONE -!----------------------------------------------------------------------- -! Control Parameters used in SETCLD,GETCLD,GETEPS: defined in RADPAR -! -! ICE012 Selects Water, Non-Mie, Mie Ice Cloud Qex,Qsc,Pi0 -! TAUWC0 Minimum Optical Depth for Water Clouds -! TAUIC0 Minimum Optical Depth for Ice Clouds -! FCLDTR Scaling Factor for Thermal Cloud Optical Depth -! FCLDSR Scaling Factor for Solar Cloud Optical Depth -! EPSCON Column Cloud Inhomogeneity EPSILON (when KCLDEP=1) -! KCLDEP Selects Cloud Inhomogeneity Option (0-4): -! KCLDEP = 0 Sets Column CLDEPS to Zero -! KCLDEP = 1 Sets Column CLDEPS to EPSCON -! KCLDEP = 2 Keeps whatever is specified in CLDEPS -! KCLDEP = 3 Uses: Column EPCOL(72,46) Climatology -! KCLDEP = 4 Uses: Ht Dep EPLOW, EPMID, EPHIG Data -! -!----------------------------------------------------------------------- -! Define Cloud Absorption Cross-Sections -! -! Selected by: ICE012 = 0 Liquid Water Droplets (N = 1 - 5) -! ICE012 = 1 Ice - Non-Spherical (N = 6 - 10) -! ICE012 = 2 Ice - Mie (Spherical) (N = 11 - 15) -! -! Define Solar,Thermal Cloud Single Scattering Albedo: SRCQPI( 6,15) -! TRCQPI(33,15) -!----------------------------------------------------------------------- - - TRCQAB(:,:) = TRCQEX(:,:) - TRCQSC(:,:) - ! 1:33,1:15 - TRCQPI(:,:) = TRCQSC(:,:)/TRCQEX(:,:) - - SRCQPI(:,:) = SRCQSC(:,:)/SRCQEX(:,:) ! 1:6,1:15 - -! Initialize GETCLD Output Parameters to Zero -! -------------------------------------------- - TRCTCA(:) = 0 ! 1:33 - TRCALK(:,:) = 0 ! 1:NL,1:33 - SRCEXT(:,:) = 1.D-20 ! 1:NL,1:6 - SRCSCT(:,:) = 0 - SRCGCB(:,:) = 0 - - END SUBROUTINE SETCLD -!----------------- -! ENTRY GETCLD -!----------------- - SUBROUTINE GETCLD - IMPLICIT NONE - REAL*8 SIZWCL, SIZICL, XRW, XMW, XPW, EPS, VEP, VEP1, VEP2, VEPP, & - TAUWCL, TAUICL, QAWATK, QPWATK, SRCGFW, QXWATK, QSWATK, & - QGWATK, XRI, XMI, XPI, QAICEK, QPICEK, SRCGFC, QXICEK, & - QSICEK, QGICEK, SCTTAU, GCBICE, SCTGCB, TCTAUW, TCTAUC, & - ALWATK, WTI, WTW, ALICEK, TRCTCI - INTEGER K, L, LBOTCW, LTOPCW, LBOTCI, LTOPCI, IRWAT, IRICE - -!----------------------------------------------------------------------- -! Define: TRCALK(LX,33) Thermal Radiation Cloud Absorption -! TRCTCA(33) Thermal Radiation Top Cloud Albedo -! -! SRCEXT(LX,6) Solar Radiation Cloud Ext Op Depth -! SRCSCT(LX,6) Solar Radiation Cloud Sct Op Depth -! SRCGCB(LX,6) Solar Radiation Cloud Asym Param g -! -! LTOPCL Top Cloud Layer Location -! LBOTCL Bot Cloud Layer Location -! -! LTOPCW Top Water Cloud Layer Location -! LBOTCW Bot Water Cloud Layer Location -! -! LTOPCI Top Ice Cloud Layer Location -! LBOTCI Bot Ice Cloud Layer Location -! -!----------------------------------------------------------------------- - - LBOTCW = 0 - LTOPCW = 0 - LBOTCI = 0 - LTOPCI = 0 - TRCTCA(:) = 0 ! 1:33 - DO L = L1, NL - TRCALK(L,:) = 0 - SRCEXT(L,:) = 1.D-20 ! 1:6 - SRCSCT(L,:) = 1.D-30 - SRCGCB(L,:) = 0 - SRCPI0(L,:) = 0 -! Water Cloud Size Interpolation -! ------------------------------ - - IF ( FTAUC*TAUWC(L)>TAUWC0 ) THEN - SIZWCL = SIZEWC(L) - LTOPCW = L - IF ( LBOTCW==0 ) LBOTCW = L - IF ( SIZWCL<15.D0 ) THEN - IF ( SIZWCL<3.0D0 ) SIZWCL = 3.0D0 - IRWAT = 2 - XRW = SIZWCL/10.0D0 - 1.00D0 - ELSE - IF ( SIZWCL>25.D0 ) SIZWCL = 25.D0 - IRWAT = 4 - XRW = SIZWCL/10.0D0 - 2.00D0 - ENDIF - XMW = 1.D0 - XRW - XRW - XPW = 1.D0 + XRW + XRW - EPS = CLDEPS(L) - VEP = EPS/(1.D0-EPS) - VEP1 = 1.D0 + VEP - TAUWCL = FTAUC*TAUWC(L) - DO K = 1, 33 - QAWATK = XMW*XPW*TRCQAB(K,IRWAT) & - - XMW*XRW*TRCQAB(K,IRWAT-1) & - + XPW*XRW*TRCQAB(K,IRWAT+1) - QPWATK = XMW*XPW*TRCQPI(K,IRWAT) & - - XMW*XRW*TRCQPI(K,IRWAT-1) & - + XPW*XRW*TRCQPI(K,IRWAT+1) - VEPP = VEP*QPWATK - TRCALK(L,K) = TRCALK(L,K) + TAUWCL*QAWATK/(VEP1-VEPP) - ENDDO - SRCGFW = SRCGSF(1) - DO K = 1, 6 - QXWATK = XMW*XPW*SRCQEX(K,IRWAT) & - - XMW*XRW*SRCQEX(K,IRWAT-1) & - + XPW*XRW*SRCQEX(K,IRWAT+1) - QSWATK = XMW*XPW*SRCQSC(K,IRWAT) & - - XMW*XRW*SRCQSC(K,IRWAT-1) & - + XPW*XRW*SRCQSC(K,IRWAT+1) - QGWATK = XMW*XPW*SRCQCB(K,IRWAT) & - - XMW*XRW*SRCQCB(K,IRWAT-1) & - + XPW*XRW*SRCQCB(K,IRWAT+1) - QPWATK = XMW*XPW*SRCQPI(K,IRWAT) & - - XMW*XRW*SRCQPI(K,IRWAT-1) & - + XPW*XRW*SRCQPI(K,IRWAT+1) - QGWATK = QGWATK*SRCGFW - VEPP = VEP*QPWATK - VEP2 = VEP1 - VEPP - SRCEXT(L,K) = SRCEXT(L,K) + TAUWCL*QXWATK/VEP1 - SRCSCT(L,K) = TAUWCL*QSWATK/(VEP1*VEP2) - SRCGCB(L,K) = QGWATK*VEP2/(VEP1-VEPP*QGWATK) - ENDDO - ENDIF -! Ice Cloud Size Interpolation -! ---------------------------- - IF ( FTAUC*TAUIC(L)>TAUIC0 ) THEN - SIZICL = SIZEIC(L) - LTOPCI = L - IF ( LBOTCI==0 ) LBOTCI = L - IF ( SIZICL<25.D0 ) THEN - IF ( SIZICL<3.0D0 ) SIZICL = 3.0D0 - IRICE = 2 + ICE012*5 - XRI = SIZICL/20.D0 - 0.75D0 - ELSE - IF ( SIZICL>75.D0 ) SIZICL = 75.D0 - IRICE = 4 + ICE012*5 - XRI = SIZICL/50.D0 - 1.00D0 - ENDIF - XMI = 1.D0 - XRI - XRI - XPI = 1.D0 + XRI + XRI - EPS = CLDEPS(L) - VEP = EPS/(1.D0-EPS) - VEP1 = 1.D0 + VEP - TAUICL = FTAUC*TAUIC(L) - DO K = 1, 33 - QAICEK = XMI*XPI*TRCQAB(K,IRICE) & - - XMI*XRI*TRCQAB(K,IRICE-1) & - + XPI*XRI*TRCQAB(K,IRICE+1) - QPICEK = XMI*XPI*TRCQPI(K,IRICE) & - - XMI*XRI*TRCQPI(K,IRICE-1) & - + XPI*XRI*TRCQPI(K,IRICE+1) - VEPP = VEP*QPICEK - TRCALK(L,K) = TRCALK(L,K) + TAUICL*QAICEK/(VEP1-VEPP) - ENDDO - - SRCGFC = SRCGSF(2) - IF ( ICE012==2 ) SRCGFC = SRCGSF(3) - DO K = 1, 6 - QXICEK = XMI*XPI*SRCQEX(K,IRICE) & - - XMI*XRI*SRCQEX(K,IRICE-1) & - + XPI*XRI*SRCQEX(K,IRICE+1) - QSICEK = XMI*XPI*SRCQSC(K,IRICE) & - - XMI*XRI*SRCQSC(K,IRICE-1) & - + XPI*XRI*SRCQSC(K,IRICE+1) - QGICEK = XMI*XPI*SRCQCB(K,IRICE) & - - XMI*XRI*SRCQCB(K,IRICE-1) & - + XPI*XRI*SRCQCB(K,IRICE+1) - QPICEK = XMI*XPI*SRCQPI(K,IRICE) & - - XMI*XRI*SRCQPI(K,IRICE-1) & - + XPI*XRI*SRCQPI(K,IRICE+1) - QGICEK = QGICEK*SRCGFC - VEPP = VEP*QPICEK - VEP2 = VEP1 - VEPP - SRCEXT(L,K) = SRCEXT(L,K) + TAUICL*QXICEK/VEP1 - SCTTAU = TAUICL*QSICEK/(VEP1*VEP2) - GCBICE = QGICEK*VEP2/(VEP1-VEPP*QGICEK) - SCTGCB = SRCSCT(L,K)*SRCGCB(L,K) + SCTTAU*GCBICE - SRCSCT(L,K) = SRCSCT(L,K) + SCTTAU - SRCGCB(L,K) = SCTGCB/SRCSCT(L,K) - ENDDO - ENDIF - ENDDO - -! ------------------------------------------------------------------ -! Identify Top Cloud (LTOPCL) and define top cloud albedo correction -! -! Full Scattering Correction: KCLDEM=1 ECLTRA=1.0 (default) -! Partial(rad99a) Correction: KCLDEM=0 ECLTRA=1.0 -! No Scattering Correction: KCLDEM=0 ECLTRA=0.0 -! -! KCLDEM=1 Top-cloud scattering correction uses TXCTPG,TSCTPG,TGCTPG -! to generate correction (over-rides old ECLTRA correction) -! (KCLDEM correction is computed in THRMAL at LTOPCL level) -! ------------------------------------------------------------------ - - LTOPCL = LTOPCI - IF ( LTOPCI>LTOPCW ) THEN - LTOPCL = LTOPCI - TCTAUC = FTAUC*TAUIC(LTOPCL) - DO K = 1, 33 - ALICEK = XMI*XPI*TRCQAL(K,IRICE) - XMI*XRI*TRCQAL(K,IRICE-1)& - + XPI*XRI*TRCQAL(K,IRICE+1) - QXICEK = XMI*XPI*TRCQEX(K,IRICE) - XMI*XRI*TRCQEX(K,IRICE-1)& - + XPI*XRI*TRCQEX(K,IRICE+1) - TRCTCA(K) = (1.D0-EXP(-FTAUC*TAUIC(LTOPCL)*QXICEK)) & - *ALICEK*ECLTRA - QSICEK = XMI*XPI*TRCQSC(K,IRICE) - XMI*XRI*TRCQSC(K,IRICE-1)& - + XPI*XRI*TRCQSC(K,IRICE+1) - QGICEK = XMI*XPI*TRCQCB(K,IRICE) - XMI*XRI*TRCQCB(K,IRICE-1)& - + XPI*XRI*TRCQCB(K,IRICE+1) - TXCTPG(K) = QXICEK*TCTAUC - TSCTPG(K) = QSICEK*TCTAUC - TGCTPG(K) = QGICEK - ENDDO - LBOTCL = LBOTCI - IF ( LBOTCW/=0 ) LBOTCL = LBOTCW - ELSEIF ( LTOPCW<1 ) THEN - LBOTCL = 0 - LTOPCL = 0 - ELSE - LTOPCL = LTOPCW - TCTAUW = FTAUC*TAUWC(LTOPCL) - DO K = 1, 33 - ALWATK = XMW*XPW*TRCQAL(K,IRWAT) - XMW*XRW*TRCQAL(K,IRWAT-1)& - + XPW*XRW*TRCQAL(K,IRWAT+1) - QXWATK = XMW*XPW*TRCQEX(K,IRWAT) - XMW*XRW*TRCQEX(K,IRWAT-1)& - + XPW*XRW*TRCQEX(K,IRWAT+1) - TRCTCA(K) = (1.D0-EXP(-FTAUC*TAUWC(LTOPCL)*QXWATK)) & - *ALWATK*ECLTRA - QSWATK = XMW*XPW*TRCQSC(K,IRWAT) - XMW*XRW*TRCQSC(K,IRWAT-1)& - + XPW*XRW*TRCQSC(K,IRWAT+1) - QGWATK = XMW*XPW*TRCQCB(K,IRWAT) - XMW*XRW*TRCQCB(K,IRWAT-1)& - + XPW*XRW*TRCQCB(K,IRWAT+1) - TXCTPG(K) = QXWATK*TCTAUW - TSCTPG(K) = QSWATK*TCTAUW - TGCTPG(K) = QGWATK - ENDDO - LBOTCL = LBOTCW - IF ( LBOTCI>=1 ) THEN - IF ( LBOTCI<=LBOTCW ) LBOTCL = LBOTCI - IF ( LTOPCI==LTOPCW ) THEN - TCTAUW = FTAUC*TAUWC(LTOPCL) - TCTAUC = FTAUC*TAUIC(LTOPCL) - WTI = TAUIC(LTOPCL)/(TAUIC(LTOPCL)+TAUWC(LTOPCL)) - WTW = TAUWC(LTOPCL)/(TAUIC(LTOPCL)+TAUWC(LTOPCL)) - DO K = 1, 33 - ALICEK = XMI*XPI*TRCQAL(K,IRICE) & - - XMI*XRI*TRCQAL(K,IRICE-1) & - + XPI*XRI*TRCQAL(K,IRICE+1) - QXICEK = XMI*XPI*TRCQEX(K,IRICE) & - - XMI*XRI*TRCQEX(K,IRICE-1) & - + XPI*XRI*TRCQEX(K,IRICE+1) - TRCTCI = (1.D0-EXP(-FTAUC*TAUIC(LTOPCL)*QXICEK)) & - *ALICEK*ECLTRA - TRCTCA(K) = WTW*TRCTCA(K) + WTI*TRCTCI - QSICEK = XMI*XPI*TRCQSC(K,IRICE) & - - XMI*XRI*TRCQSC(K,IRICE-1) & - + XPI*XRI*TRCQSC(K,IRICE+1) - QGICEK = XMI*XPI*TRCQCB(K,IRICE) & - - XMI*XRI*TRCQCB(K,IRICE-1) & - + XPI*XRI*TRCQCB(K,IRICE+1) - TXCTPG(K) = TXCTPG(K) + QXICEK*TCTAUC - SCTGCB = TSCTPG(K)*TGCTPG(K) + QSICEK*TCTAUC*QGICEK - TSCTPG(K) = TSCTPG(K) + QSICEK*TCTAUC - TGCTPG(K) = SCTGCB/(1.D-10+TSCTPG(K)) - ENDDO - ENDIF - ENDIF - ENDIF - - END SUBROUTINE GETCLD - -!-------------------------------- -! ENTRY UPDEPS(JYEARE,JJDAYE) -!-------------------------------- - SUBROUTINE UPDEPS(JYEARE,JJDAYE) -! Select ISCCP-Based Cloud Heterogeneity Time Dependence -! ------------------------------------------------------ - IMPLICIT NONE - INTEGER, INTENT(IN) :: JYEARE, JJDAYE - REAL*8 XJDAY, XMO, WTMJ, WTMI - INTEGER MI, MJ - - XJDAY = JJDAYE - 0.999D0 - XMO = XJDAY/30.5D0 + .5D0 - MI = XMO - WTMJ = XMO - MI - WTMI = 1.D0 - WTMJ - IF ( MI<1 ) MI = 12 - MJ = MI + 1 - IF ( MJ>12 ) MJ = 1 - - EPLOW(:,:) = WTMI*EPLMHC(:,:,MI,1) + WTMJ*EPLMHC(:,:,MJ,1) ! 72,46 - EPMID(:,:) = WTMI*EPLMHC(:,:,MI,2) + WTMJ*EPLMHC(:,:,MJ,2) - EPHIG(:,:) = WTMI*EPLMHC(:,:,MI,3) + WTMJ*EPLMHC(:,:,MJ,3) - EPCOL(:,:) = WTMI*EPLMHC(:,:,MI,4) + WTMJ*EPLMHC(:,:,MJ,4) - - END SUBROUTINE UPDEPS - -!----------------- -! ENTRY GETEPS -!----------------- - SUBROUTINE GETEPS -! ---------------------------------------------------------- -! Select Cloud Heterogeneity CLDEPS Options -! EPSCON Column Cloud Inhomogeneity EPSILON (when KCLDEP=1) -! KCLDEP Selects Cloud Inhomogeneity Option (0-4): -! KCLDEP = 0 Sets Column CLDEPS to Zero -! KCLDEP = 1 Sets Column CLDEPS to EPSCON -! KCLDEP = 2 Keeps whatever is specified in CLDEPS -! KCLDEP = 3 Uses: Column EPCOL(72,46) Climatology -! KCLDEP = 4 Uses: Ht Dep EPLOW, EPMID, EPHIG Data -! -------------------------------------------------- - IMPLICIT NONE - INTEGER L - - IF ( KCLDEP==0 ) CLDEPS(L1:NL) = 0 - IF ( KCLDEP==1 ) CLDEPS(L1:NL) = EPSCON - IF ( KCLDEP==3 ) CLDEPS(L1:NL) = EPCOL(ILON,JLAT) - IF ( KCLDEP==4 ) THEN - DO L = L1, NL - CLDEPS(L) = EPMID(ILON,JLAT) - IF ( PLB(L)>750 ) CLDEPS(L) = EPLOW(ILON,JLAT) - IF ( PLB(L)<430 ) CLDEPS(L) = EPHIG(ILON,JLAT) - ENDDO - ENDIF - - END SUBROUTINE GETEPS - - SUBROUTINE TAUGAS - IMPLICIT NONE -! ------------------------------------------------------------- -! TAUGAS INPUT REQUIRES: L1,NL,PL,DPL,TLM,ULGAS, TAUTBL,TAUWV0 -! TAUCD0,TAUO30, XKCFC,H2OCN8,H2OCF8 -! ULOX,DUX,XTRUP,XTU0,XTRDN,XTD0 -! DXUP2,DXDN2,DXUP3,DXDN3,DXUP6,DXDN6 -! DXUP7,DXDN7,DXUP8,DXDN8,DXUP9,DXDN9 -! DXUP13,DXDN13 -! TAUGAS OUTPUT DATA IS: TRGXLK,XTRU,XTRD -! ---------------------------------------------------------- - - INTEGER, PARAMETER :: NPU2 = 14, NPU = 5 - REAL*8, PARAMETER :: TLOX = 181.D0, DTX = 23.D0, P0 = 1013.25D0 - - REAL*8, PARAMETER :: PX(NPX) = (/1000D0,750D0,500D0,300D0,200D0,& - 100D0,50D0,20D0,10D0,5D0,2D0,1D0,.5D0,.2D0,& - .1D0,.03D0,.01D0,.003D0,.001D0/) - - INTEGER, PARAMETER :: NGX(4) = (/12,12,8,33/), IG1X(4) & - = (/2,14,26,1/) - REAL*8, PARAMETER :: PDPU2(NPU2) & - = (/1.D4,1.D5,2.D5,5.D5,1.D6,2.D6,5.D6, & - 1.D7,2.D7,5.D7,1.D8,2.D8,5.D8,1.D9/) - REAL*8, PARAMETER :: PU(NPU) = (/50.,200.,800.,3200.,12800./) - INTEGER, PARAMETER :: IGASX(21) & - = (/1,2,3,1,1,2,2,3,3,6,6,6,7,7,13,13,8,8,& - 9,9,1/) - INTEGER, PARAMETER :: KGX(21) & - = (/1,2,3,2,3,1,3,1,2,1,2,3,1,3,1,3,2,3,2,& - 3,4/) - INTEGER, PARAMETER :: NUX(16) & - = (/25,9,9,9,9,5,5,5,5,2,2,2,2,2,2,2/) - INTEGER, PARAMETER :: IGUX(16) & - = (/0,300,408,480,588,660,720,760,820,880,& - 904,928,944,968,984,1008/) - - - REAL*8, PARAMETER :: XKH2OW(8) & - = (/.432D-5,.943D-5,.188D-4,.352D-4, & - .623D-4,.105D-3,.170D-3,.262D-3/) - - REAL*8, PARAMETER :: XKCFCW(8,2) & - = RESHAPE((/11.0,11.7,11.5,10.9,10.3,9.90, & - 9.90,9.90,5.75,5.72,5.95,5.95,5.90,6.51, & - 6.51,6.51/),(/8,2/)) - - REAL*8, PARAMETER :: PCF(NLCF) & - = (/0.98981D+03,0.96840D+03,0.94446D+03, & - 0.91796D+03,0.88891D+03,0.85579D+03, & - 0.81757D+03,0.77425D+03,0.72686D+03, & - 0.67692D+03,0.62545D+03,0.57296D+03, & - 0.52098D+03,0.47104D+03,0.42365D+03, & - 0.37932D+03,0.33855D+03,0.30186D+03, & - 0.26874D+03,0.23867D+03,0.21115D+03, & - 0.18567D+03,0.16172D+03,0.13900D+03, & - 0.11800D+03,0.99000D+02,0.81500D+02, & - 0.65000D+02,0.50000D+02,0.37000D+02, & - 0.25500D+02,0.15000D+02,0.78100D+01, & - 0.43900D+01,0.24700D+01,0.13900D+01, & - 0.78100D+00,0.43900D+00,0.24700D+00, & - 0.13900D+00,0.75000D-01,0.35000D-01, & - 0.10000D-01/) - - REAL*8, PARAMETER :: DPCF(NLCF) & - = (/0.20380D+02,0.22430D+02,0.25470D+02, & - 0.27520D+02,0.30580D+02,0.35670D+02, & - 0.40770D+02,0.45860D+02,0.48920D+02, & - 0.50960D+02,0.51980D+02,0.53000D+02, & - 0.50960D+02,0.48920D+02,0.45860D+02, & - 0.42810D+02,0.38720D+02,0.34660D+02, & - 0.31590D+02,0.28540D+02,0.26500D+02, & - 0.24460D+02,0.23440D+02,0.22000D+02, & - 0.20000D+02,0.18000D+02,0.17000D+02, & - 0.16000D+02,0.14000D+02,0.12000D+02, & - 0.11000D+02,0.10000D+02,0.43800D+01, & - 0.24600D+01,0.13800D+01,0.78000D+00, & - 0.43800D+00,0.24600D+00,0.13800D+00, & - 0.78000D-01,0.50000D-01,0.30000D-01, & - 0.20000D-01/) - - REAL*8, PARAMETER :: PLBCF(NLCF+1) & - = (/0.10000D+04,0.97962D+03,0.95719D+03, & - 0.93172D+03,0.90420D+03,0.87362D+03, & - 0.83795D+03,0.79718D+03,0.75132D+03, & - 0.70240D+03,0.65144D+03,0.59946D+03, & - 0.54646D+03,0.49550D+03,0.44658D+03, & - 0.40072D+03,0.35791D+03,0.31919D+03, & - 0.28453D+03,0.25294D+03,0.22440D+03, & - 0.19790D+03,0.17344D+03,0.15000D+03, & - 0.12800D+03,0.10800D+03,0.90000D+02, & - 0.73000D+02,0.57000D+02,0.43000D+02, & - 0.31000D+02,0.20000D+02,0.10000D+02, & - 0.56200D+01,0.31600D+01,0.17800D+01, & - 0.10000D+01,0.56200D+00,0.31600D+00, & - 0.17800D+00,0.10000D+00,0.50000D-01, & - 0.20000D-01,0.00000D+00/) - - - REAL*8, PARAMETER :: DLOG2 = .30103D0, ULMNH2 = 1.85124D0, & - ULMNCH = -.8160D0, ULMNN2 = -1.527D0, & - ULMNF1 = -4.780D0, ULMNO3 = -1.368D0, & - ULMNCO = 1.523D0, ULMNF2 = -4.524D0, & - USO2S = .042D0 - REAL*8, DIMENSION(NLCF,NRCF) :: XTU, XTD - REAL*8, DIMENSION(NLCF,NWVCF,NRCF) :: DXUP, DXDN - REAL*8 PRATCF(NLCF) - INTEGER MLGAS(21) - INTEGER I, IM, L, LCF, LCFdn, LCFup, NLPrat, IULOW, IPX, ITX, & - IGAS, NG, KK, IK1, IK2, IPU, IK, NU, IUA, nsum, IUB, & - IH2O0, IG, ICDlow, ICO20, IO3low, IO30, IUW, IU1, IU2, & - i2u1, i2u2, i3u1, i3u2, i6u1, i6u2, i7u1, i7u2, i8u1, & - i8u2, i9u1, i9u2 - - REAL*8 UH2O, UCO2L, UO3LL, UCH4L, UN2OL, UCF1L, UCF2L, USO2, & - UCH4L1, CH4RAT, DUH2, DU1, DU2, DUCO, D2U1, D2U2, DUO3, & - D3U1, D3U2, DUCH, D7U1, D7U2, DUN2, D6U1, D6U2, DUF1, D8U1,& - D8U2, DUF2, D9U1, D9U2, SUM1, SUM2, sumPR, TAUT1, TAUT2, & - TAUCF, TAUIPG, TAUSUM, TAU11, TAU12, QAA, QAB, QBA, QBB, & - PLL, PU2, U, UP, UGAS, UAA, UAB, UBA, UBB, WPB, WTB, WTPU, & - XA, XB, XK, XUA, XUB, WAA, WAB, WBA, WBB, WAAA, WAAB, WABA,& - WABB, WBAA, WBAB, WBBA, WBBB - REAL*8 PRAT(LX), WT(LX) - INTEGER LCFofL(LX) - - ! The variation of correction factors with the water vapor - ! profile is determined via a two-step procedure. - ! As for the other absorbers, a lookup-table dependence upon - ! total column absorber amount is constructed by multiplying - ! a reference vapor profile by a set of powers of 2 that index - ! the tables. - ! The actual shape of the water vapor profile for which fluxes - ! are being computed is then folded into this column-oriented - ! framework via per-layer interpolations for downward/upward flux - ! correction factors that select the reference profile having - ! the same column amount above/below each layer. - ! In rare cases for which water vapor mixing ratios increase upward - ! in the lower troposphere, an additional correction is performed. - ! Since the interpolations in absorber amount are performed - ! on the layers of the reference atmosphere, a call to REPART - ! is needed to regrid the GCM water vapor to the reference layers. - - ! Interp. weights/indices and their prerequisites for downward-flux - ! correction factors - REAL*8, DIMENSION(NLCF) :: qabove, uh2otl, duh2o1dn, duh2o2dn - INTEGER, DIMENSION(NLCF) :: iuh2o1dn, iuh2o2dn - REAL*8, PARAMETER :: UCMRCF(NLCF) & - = (/0.10000D+01,0.11031D+01,0.12329D+01, & - 0.14042D+01,0.16222D+01,0.19138D+01, & - 0.23456D+01,0.29937D+01,0.40048D+01, & - 0.55959D+01,0.81519D+01,0.12375D+02, & - 0.19808D+02,0.32524D+02,0.54780D+02, & - 0.93174D+02,0.15748D+03,0.25287D+03, & - 0.37309D+03,0.50049D+03,0.60868D+03, & - 0.71320D+03,0.84524D+03,0.10234D+04, & - 0.12685D+04,0.16078D+04,0.20909D+04, & - 0.28557D+04,0.41673D+04,0.66299D+04, & - 0.12554D+05,0.26315D+05,0.59589D+05, & - 0.10604D+06,0.18859D+06,0.33480D+06, & - 0.59602D+06,0.10608D+07,0.18872D+07, & - 0.33520D+07,0.59729D+07,0.11972D+08, & - 0.30143D+08/) - - - ! Interp. weights/indices and their prerequisites for upward-flux - ! correction factors - REAL*8, DIMENSION(NLCF) :: qbelow, uh2oul, duh2o1up, duh2o2up - INTEGER, DIMENSION(NLCF) :: iuh2o1up, iuh2o2up - REAL*8, PARAMETER :: UCMUCF(NLCF) & - = (/0.10701D+02,0.52946D+01,0.34738D+01, & - 0.26072D+01,0.20943D+01,0.17432D+01, & - 0.15016D+01,0.13328D+01,0.12176D+01, & - 0.11398D+01,0.10879D+01,0.10532D+01, & - 0.10317D+01,0.10186D+01,0.10108D+01, & - 0.10064D+01,0.10040D+01,0.10027D+01, & - 0.10020D+01,0.10016D+01,0.10014D+01, & - 0.10012D+01,0.10010D+01,0.10008D+01, & - 0.10006D+01,0.10005D+01,0.10004D+01, & - 0.10002D+01,0.10002D+01,0.10001D+01, & - 0.10000D+01,0.10000D+01,0.10000D+01, & - 0.10000D+01,0.10000D+01,0.10000D+01, & - 0.10000D+01,0.10000D+01,0.10000D+01, & - 0.10000D+01,0.10000D+01,0.10000D+01, & - 0.10000D+01/) - - REAL*8 :: dudp(LX), ddudp - ! ddudp is vertical gradient of water vapor - REAL*8 :: dxtru3_10(10) - ! optional correction of top 10 layers <.2mb - -#ifdef TAPER_UTCF - REAL*8 :: pcen_tap, wt_one, pwid_tap -#endif - - ! compute QABOVE/QBELOW, the WV amount above/below each reference level - CALL REPART(ULGAS(1,1),PLB,NL+1,QABOVE,PLBCF,NLCF+1) - QBELOW = QABOVE - DO L = 2, NLCF - QBELOW(L) = QBELOW(L) + QBELOW(L-1) - ENDDO - DO L = NLCF - 1, 1, -1 - QABOVE(L) = QABOVE(L) + QABOVE(L+1) - ENDDO - DO L = 1, NLCF - IF ( QABOVE(L)>0. ) THEN - UH2OTL(L) = LOG10(UCMRCF(L)*QABOVE(L)) - ELSE - UH2OTL(L) = 0. - ! should not happen - ENDIF - IF ( QBELOW(L)>0. ) THEN - UH2OUL(L) = LOG10(UCMUCF(L)*QBELOW(L)) - ELSE - UH2OUL(L) = 0. - ! below ground - ENDIF - ENDDO - -! MLGAS DEF. -! ---------- -! H2O: 1,4,5 CO2: 2,6,7 O3: 3,8,9 N2O: 10,11,12 CH4: 13,14 -! SO2: 15,16 CFC: 17-20 WVCON: 21 - - MLGAS(:) = 1 - ! 1:21 - -! KWVCON = ON/OFF flag for water vapor continuum absorption -! --------------------------------------------------------- - IF ( KWVCON<1 ) MLGAS(21) = 0 - -!**** Find correction factors XTU and XTD -! Prepare interpolation from PL to PCF pressure levels - LCF = 2 - NLPrat = NL - DO L = L1, NL - PLL = PL(L) -! Find LCF s.t. PLLmid is between PCF(LCF) and PCF(LCF-1) - DO WHILE ( PLLNLCF ) THEN ! PL-levels higher than PCF_top - NLPrat = L - 1 - GOTO 100 - ENDIF - ENDDO - LCFofL(L) = LCF - WT(L) = (PLL-PCF(LCF))/(PCF(LCF-1)-PCF(LCF)) - WT(L) = MIN(WT(L),1D0) - Prat(L) = DPL(L)/(DPCF(LCF-1)*WT(L)+DPCF(LCF)*(1-WT(L))) - ENDDO - - 100 ICDlow = 0 ! default: CO2 not low - IO3low = 0 ! default: O3 not low - IUlow = 0 ! water vapor not low - - UH2O = 1D-10 + SUM(ULGAS(L1:NL,1)) - IF ( UH2O<1.1D-10 ) THEN ! low water vapor - IUlow = 1 - XTU(:,:) = XTU0(:,:) ! 1:NLCF,1:NRCF - XTD(:,:) = XTD0(:,:) ! 1:NLCF,1:NRCF - GOTO 180 ! if no water vapor - ENDIF - - UCO2L = LOG10(1D-10+SUM(ULGAS(L1:NL,2))) - UO3LL = LOG10(1D-10+SUM(ULGAS(L1:NL,3))) - UCH4L = LOG10(1D-10+SUM(ULGAS(L1:NL,7))) - UN2OL = LOG10(1D-10+SUM(ULGAS(L1:NL,6))) - UCF1L = LOG10(1D-10+SUM(ULGAS(L1:NL,8))) - UCF2L = LOG10(1D-10+SUM(ULGAS(L1:NL,9))) - USO2 = SUM(ULGAS(L1:NL,13)) - - CH4RAT = 1. - IF ( UCH4L>.7 ) THEN ! high CH4 concentration case - IF ( UCH4L<1.1 ) THEN - UCH4L1 = 1.15*UCH4L - .1 - ELSEIF ( UCH4L<1.7 ) THEN - UCH4L1 = 0.70*UCH4L + .4 - ELSE - UCH4L1 = 0.375*UCH4L + .95 - ENDIF - CH4RAT = 10**UCH4L1/10**UCH4L - UCH4L = UCH4L1 - ENDIF - - IF ( UCO2L<-9.958607315D0 ) ICDlow = 1 ! if UCO2<1.1d-10 (low CO2) - IF ( UO3LL<-9.6 ) IO3LOW = 1 ! low ozone - - DUCO = UCO2L - ULMNCO - IF ( DUCO<0. ) DUCO = 0. - I2U1 = DUCO/DLOG2 + 1 - IF ( I2U1<1 ) I2U1 = 1 - IF ( I2U1>NUCF-1 ) I2U1 = NUCF - 1 - I2U2 = I2U1 + 1 - D2U1 = DUCO - (I2U1-1)*DLOG2 - D2U2 = DLOG2 - D2U1 - - DUO3 = UO3LL - ULMNO3 - IF ( DUO3<0. ) DUO3 = 0. - I3U1 = DUO3/DLOG2 + 1 - IF ( I3U1<1 ) I3U1 = 1 - IF ( I3U1>NUCF-1 ) I3U1 = NUCF - 1 - I3U2 = I3U1 + 1 - D3U1 = DUO3 - (I3U1-1)*DLOG2 - D3U2 = DLOG2 - D3U1 - - DUCH = UCH4L - ULMNCH - I7U1 = DUCH/DLOG2 + 1 - IF ( I7U1<1 ) I7U1 = 1 - IF ( I7U1>NUCF-1 ) I7U1 = NUCF - 1 - I7U2 = I7U1 + 1 - D7U1 = DUCH - (I7U1-1)*DLOG2 - D7U2 = DLOG2 - D7U1 - - DUN2 = UN2OL - ULMNN2 - IF ( DUN2<0. ) DUN2 = DUN2*.5 - IF ( DUN2<-.56 ) DUN2 = -.56 - I6U1 = DUN2/DLOG2 + 1 - IF ( I6U1<1 ) I6U1 = 1 - IF ( I6U1>NUCF-1 ) I6U1 = NUCF - 1 - I6U2 = I6U1 + 1 - D6U1 = DUN2 - (I6U1-1)*DLOG2 - D6U2 = DLOG2 - D6U1 - - DUF1 = UCF1L - ULMNF1 - IF ( DUF1<-.25 ) DUF1 = -.25 - I8U1 = DUF1/DLOG2 + 1 - IF ( I8U1<1 ) I8U1 = 1 - IF ( I8U1>NUCF-1 ) I8U1 = NUCF - 1 - I8U2 = I8U1 + 1 - D8U1 = DUF1 - (I8U1-1)*DLOG2 - D8U2 = DLOG2 - D8U1 - - DUF2 = UCF2L - ULMNF2 - IF ( DUF2<-.2 ) DUF2 = -.2 - I9U1 = DUF2/DLOG2 + 1 - IF ( I9U1<1 ) I9U1 = 1 - IF ( I9U1>NUCF-1 ) I9U1 = NUCF - 1 - I9U2 = I9U1 + 1 - D9U1 = DUF2 - (I9U1-1)*DLOG2 - D9U2 = DLOG2 - D9U1 -! IF(I9U1.GT.9xxxfixthis) THEN -! I9U1=1 -! I9U2=2 -! D9U1=0. -! D9U2=0. -! end if - -! Find pressure ratios on PCF levels by averaging Prat -! Fill missed layers copying from the nearest layer above - LCFdn = 1 ! bottom of current segment - LCFup = LCFofL(L1) ! top of current segment - sumPR = Prat(L1) - PratCF(LCFdn:LCFup) = sumPR - nsum = 1 - DO L = L1 + 1, NLPrat - LCF = LCFofL(L) - IF ( LCF==LCFup ) THEN - ! update the current PratLCF segment - sumPR = sumPR + Prat(L) - NSUM = NSUM + 1 - PratCF(LCFdn:LCFup) = sumPR/DFLOAT(NSUM) - ELSE ! start next PratLCF segment - sumPR = Prat(L) - PratCF(LCFup+1:LCF) = sumPR - NSUM = 1 - LCFdn = LCFup + 1 - LCFup = LCF - ENDIF - ENDDO - PratCF(LCFup+1:NLCF) = PratCF(LCFup) - ! at top fill from below - - DO I = 1, NLCF - DUH2 = UH2OUL(I) - ULMNH2 - IF ( DUH2<0. ) DUH2 = 0. - IU1 = DUH2/DLOG2 + 1. - IF ( IU1<1 ) IU1 = 1 - IF ( IU1>NWVCF-1 ) IU1 = NWVCF - 1 - IU2 = IU1 + 1 - DUH2O1up(I) = DUH2 - (IU1-1)*DLOG2 - DUH2O2up(I) = DLOG2 - DUH2O1up(I) - IUH2O1up(I) = IU1 - IUH2O2up(I) = IU2 - ENDDO - - DO I = 1, NLCF - DUH2 = UH2OTL(I) - ULMNH2 - IF ( DUH2<0. ) DUH2 = 0. - IU1 = DUH2/DLOG2 + 1. - IF ( IU1<1 ) IU1 = 1 - IF ( IU1>NWVCF-1 ) IU1 = NWVCF - 1 - IU2 = IU1 + 1 - DUH2O1dn(I) = DUH2 - (IU1-1)*DLOG2 - DUH2O2dn(I) = DLOG2 - DUH2O1dn(I) - IUH2O1dn(I) = IU1 - IUH2O2dn(I) = IU2 - ENDDO - - DO IM = 1, NRCF - DO I = 1, NLCF - DO IUW = IUH2O1up(I), IUH2O2up(I) - - SUM1 = (DXUP2(I,IUW,I2U2,IM)*D2U1+DXUP2(I,IUW,I2U1,IM) & - *D2U2) & - + (DXUP3(I,IUW,I3U2,IM)*D3U1+DXUP3(I,IUW,I3U1,IM) & - *D3U2) + PratCF(I) & - *((DXUP7(I,IUW,I7U2,IM)*D7U1+DXUP7(I,IUW,I7U1,IM) & - *D7U2) & - +(DXUP6(I,IUW,I6U2,IM)*D6U1+DXUP6(I,IUW,I6U1,IM) & - *D6U2)) & - + (DXUP8(I,IUW,I8U2,IM)*D8U1+DXUP8(I,IUW,I8U1,IM) & - *D8U2) & - + (DXUP9(I,IUW,I9U2,IM)*D9U1+DXUP9(I,IUW,I9U1,IM) & - *D9U2) - DXUP(I,IUW,IM) = SUM1/DLOG2 + DXUP13(I,IUW,IM)*USO2/USO2S - ENDDO - DO IUW = IUH2O1dn(I), IUH2O2dn(I) - - SUM2 = (DXDN2(I,IUW,I2U2,IM)*D2U1+DXDN2(I,IUW,I2U1,IM) & - *D2U2) & - + (DXDN3(I,IUW,I3U2,IM)*D3U1+DXDN3(I,IUW,I3U1,IM) & - *D3U2) + PratCF(I) & - *((DXDN7(I,IUW,I7U2,IM)*D7U1+DXDN7(I,IUW,I7U1,IM) & - *D7U2) & - +(DXDN6(I,IUW,I6U2,IM)*D6U1+DXDN6(I,IUW,I6U1,IM) & - *D6U2)) & - + (DXDN8(I,IUW,I8U2,IM)*D8U1+DXDN8(I,IUW,I8U1,IM) & - *D8U2) & - + (DXDN9(I,IUW,I9U2,IM)*D9U1+DXDN9(I,IUW,I9U1,IM) & - *D9U2) - DXDN(I,IUW,IM) = SUM2/DLOG2 + DXDN13(I,IUW,IM)*USO2/USO2S - ENDDO - ENDDO - ! LAYER - ENDDO ! IM - - DO IM = 1, NRCF - DO I = 1, NLCF - DU1 = DUH2O1up(I) - DU2 = DUH2O2up(I) - IU1 = IUH2O1up(I) - IU2 = IUH2O2up(I) - XTU(I,IM) = ((XTRUP(I,IU2,IM)+DXUP(I,IU2,IM))*DU1+(XTRUP(I, & - IU1,IM)+DXUP(I,IU1,IM))*DU2)/DLOG2 - DU1 = DUH2O1dn(I) - DU2 = DUH2O2dn(I) - IU1 = IUH2O1dn(I) - IU2 = IUH2O2dn(I) - XTD(I,IM) = ((XTRDN(I,IU2,IM)+DXDN(I,IU2,IM))*DU1+(XTRDN(I, & - IU1,IM)+DXDN(I,IU1,IM))*DU2)/DLOG2 - ENDDO - ENDDO - -!**** Interpolate correction factors to model grid: XTU/D=>XTRU/D - - 180 IF ( transmission_corrections ) THEN - ! note window region is position 1 in XTRU, XTRD - XTRU(:,1) = 1. - XTRD(:,1) = 1. - - DO L = L1, MIN(NLPrat,NL-1) - LCF = LCFofL(L) - XTRU(L,2:NRCF+1) = 1. - PRAT(L) & - *(1.-XTU(LCF-1,:)*WT(L)-XTU(LCF,:) & - *(1.-WT(L))) - XTRD(L,2:NRCF+1) = 1. - PRAT(L) & - *(1.-XTD(LCF-1,:)*WT(L)-XTD(LCF,:) & - *(1.-WT(L))) - ENDDO - - DO L = NLPrat + 1, NL - 1 - XTRU(L,2:NRCF+1) = XTU(NLCF,:) - XTRD(L,2:NRCF+1) = XTD(NLCF,:) - ENDDO - - XTRU(NL,2:NRCF+1) = 1. - XTRD(NL,2:NRCF+1) = 1. - -#ifdef TAPER_UTCF - ! force upward transmission correction factors to 1 near the model top - !pcen_tap = 1d0 ! center pressure (mb) of blending region - pcen_tap = .1D0 - ! center pressure (mb) of blending region - pwid_tap = .5D0*pcen_tap - ! width (mb) of blending region - DO l = nl, 1, -1 - wt_one = .5D0*(1D0+TANH((pcen_tap-plb(l))/pwid_tap)) - ! blending weight - xtru(l,2:NRCF+1) = wt_one*1D0 + (1D0-wt_one) & - *xtru(l,2:NRCF+1) - xtrd(l,2:NRCF+1) = wt_one*1D0 + (1D0-wt_one) & - *xtrd(l,2:NRCF+1) - IF ( wt_one<1D-3 ) EXIT - ! far from model top - ENDDO -#endif - - ! correction for cases when water vapor mixing ratio increases upward - DO L = 1, NL - DUDP(L) = ULGAS(L,1)/(PLB(L)-PLB(L+1)) - ENDDO - DO L = 2, NL - 1 - IF ( PLB(L)<600. ) EXIT - !DDUDP=(DUDP(L)-DUDP(L+1))/(PLB(L)-PLB(L+1)) - DDUDP = (DUDP(L-1)-DUDP(L))/(PL(L-1)-PL(L)) - IF ( DDUDP>=0. ) CYCLE - IF ( DDUDP>-.00037D0 ) THEN ! avoid nonzero effect for DDUDP==0 - XTRD(L,2) = XTRD(L,2) - 100D0*DDUDP - ELSE - XTRD(L,2) = XTRD(L,2) + (.035D0-5.25D0*DDUDP) - ENDIF - ENDDO - - ELSE - XTRU(:,:) = 1. - XTRD(:,:) = 1. - ENDIF - -!**** Find TRGXLK - TRGXLK(L1:NL,1:33) = 0.D0 - IPX = 2 - DO L = L1, NL - DO -! Locate model layer pressure between IPX and IPX-1 - WPB = (PL(L)-PX(IPX))/(PX(IPX-1)-PX(IPX)) - IF ( WPB>=0 .OR. IPX>=NPX ) THEN -! Locate model layer temperature between ITX and ITX+1 - WTB = (TLM(L)-TLOX)/DTX + 1 - ITX = WTB - IF ( ITX<1 ) ITX = 1 - IF ( ITX>=NTX ) ITX = NTX - 1 - WTB = WTB - ITX - - WBB = WPB*WTB - WBA = WPB - WBB - WAB = WTB - WBB - WAA = 1 - (WBB+WBA+WAB) - - DO IGAS = 1, 21 - IF ( MLGAS(IGAS)>=1 ) THEN - KK = IG1X(KGX(IGAS)) - NG = NGX(KGX(IGAS)) - UGAS = ULGAS(L,IGASX(IGAS)) - IF ( IGAS==13 .OR. IGAS==14 ) UGAS = UGAS*CH4RAT - IF ( IGAS==17 .OR. IGAS==18 ) UGAS = UGAS + & - ULGAS(L,11) - - IF ( IGAS>=21 ) THEN - -! IGAS = 21 Apply water vapor continuum absorption -! --------- -------------------------------------- -! KCSELF = ON/FF flag for H2O self broadening continuum -! ----------------------------------------------------- - IF ( KCSELF>0 ) THEN - - DO IK1 = 1, 2 - IF ( IK1==1 ) THEN - IK2 = 1 - U = UGAS*1.15D0 - ! thermal K-domain 1 - ELSE - ! IK1=2 - IK2 = 33 - U = UGAS*XCSELF - ! thermal K-domain 2-33 - ENDIF - PU2 = PL(L)/DPL(L)*U**2 - IF ( PU2>PDPU2(1) ) THEN - IPU = 2 - DO WHILE ( PU2>PDPU2(IPU) .AND. & - IPU=1 ) THEN - KK = IG1X(KGX(IGAS)) - DO IK1 = 1, 2 - IF ( IK1==1 ) THEN - IK2 = 1 - U = UGAS*1.15D0 - ELSE - ! IK1=2 - IK2 = 33 - U = UGAS*XCFORN - ENDIF - UP = PL(L)/P0*U - IF ( UP>PU(1) ) THEN - IPU = 2 - DO WHILE ( UP>PU(IPU) .AND. IPU=NU-1 ) THEN - XUA = NU - 1 - IUA = NU - 2 - QAA = UGAS/(ULOX(IPX,IGAS)+DUX(IPX,IGAS) & - *(NU-2)) - QAB = UGAS/(ULOX(IPX,IGAS)+DUX(IPX,IGAS) & - *(NU-1)) - ENDIF - QBA = 1 - QBB = 1 - IF ( XUB<=0 ) THEN - XUB = 0 - IUB = 0 - QBA = UGAS/ULOX(IPX-1,IGAS) - QBB = UGAS/(ULOX(IPX-1,IGAS)+DUX(IPX-1,IGAS)) - ENDIF - IF ( XUB>=NU-1 ) THEN - XUB = NU - 1 - IUB = NU - 2 - QBA = UGAS/(ULOX(IPX-1,IGAS)+DUX(IPX-1,IGAS) & - *(NU-2)) - QBB = UGAS/(ULOX(IPX-1,IGAS)+DUX(IPX-1,IGAS) & - *(NU-1)) - ENDIF - UAB = XUA - IUA - UBB = XUB - IUB - UAA = 1 - UAB - UBA = 1 - UBB - - WAAA = WAA*UAA*QAA - WAAB = WAA*UAB*QAB - WABA = WAB*UAA*QAA - WABB = WAB*UAB*QAB - WBAA = WBA*UBA*QBA - WBAB = WBA*UBB*QBB - WBBA = WBB*UBA*QBA - WBBB = WBB*UBB*QBB - - IH2O0 = 0 - IF ( (IGAS==6 .OR. IGAS==8 .OR. IGAS==10 .OR. & - IGAS==13 .OR. IGAS==15) .AND. IULOW==1 ) & - IH2O0 = 1 - - ICO20 = 0 - IF ( (IGAS==4 .OR. IGAS==9 .OR. IGAS==11) .AND. & - ICDLOW==1 ) ICO20 = 1 - - IO30 = 0 - IF ( (IGAS==5 .OR. IGAS==7 .OR. IGAS==12 .OR. & - IGAS==14 .OR. IGAS==16) .AND. IO3LOW==1 ) & - IO30 = 1 - -!!! WARNING: If IH2O0+ICO20+IO30=2 accuracy is reduced -!!! WARNING: If IH2O0+ICO20+IO30=3 result is unusable - - DO IG = 1, NG - IF ( IH2O0==1 ) THEN - TAUIPG = WAAA*TAUWV0(IG+IGUX(IGAS)+NG*IUA,& - ITX,IPX) & - + WAAB*TAUWV0(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX,IPX) & - + WABA*TAUWV0(IG+IGUX(IGAS) & - +NG*IUA,ITX+1,IPX) & - + WABB*TAUWV0(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX+1,IPX) & - + WBAA*TAUWV0(IG+IGUX(IGAS) & - +NG*IUB,ITX,IPX-1) & - + WBAB*TAUWV0(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX,IPX-1) & - + WBBA*TAUWV0(IG+IGUX(IGAS) & - +NG*IUB,ITX+1,IPX-1) & - + WBBB*TAUWV0(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX+1,IPX-1) - ! low H2O - ELSEIF ( ICO20==1 ) THEN - TAUIPG = WAAA*TAUCD0(IG+IGUX(IGAS)+NG*IUA,& - ITX,IPX) & - + WAAB*TAUCD0(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX,IPX) & - + WABA*TAUCD0(IG+IGUX(IGAS) & - +NG*IUA,ITX+1,IPX) & - + WABB*TAUCD0(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX+1,IPX) & - + WBAA*TAUCD0(IG+IGUX(IGAS) & - +NG*IUB,ITX,IPX-1) & - + WBAB*TAUCD0(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX,IPX-1) & - + WBBA*TAUCD0(IG+IGUX(IGAS) & - +NG*IUB,ITX+1,IPX-1) & - + WBBB*TAUCD0(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX+1,IPX-1) - ! low CO2 - ELSEIF ( IO30==1 ) THEN - TAUIPG = WAAA*TAUO30(IG+IGUX(IGAS)+NG*IUA,& - ITX,IPX) & - + WAAB*TAUO30(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX,IPX) & - + WABA*TAUO30(IG+IGUX(IGAS) & - +NG*IUA,ITX+1,IPX) & - + WABB*TAUO30(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX+1,IPX) & - + WBAA*TAUO30(IG+IGUX(IGAS) & - +NG*IUB,ITX,IPX-1) & - + WBAB*TAUO30(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX,IPX-1) & - + WBBA*TAUO30(IG+IGUX(IGAS) & - +NG*IUB,ITX+1,IPX-1) & - + WBBB*TAUO30(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX+1,IPX-1) - ! low O3 - ELSE - !! if H2O, CO2, O3 are present (I..0=0) - TAUIPG = WAAA*TAUTBL(IG+IGUX(IGAS)+NG*IUA,& - ITX,IPX) & - + WAAB*TAUTBL(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX,IPX) & - + WABA*TAUTBL(IG+IGUX(IGAS) & - +NG*IUA,ITX+1,IPX) & - + WABB*TAUTBL(IG+IGUX(IGAS) & - +NG*(IUA+1),ITX+1,IPX) & - + WBAA*TAUTBL(IG+IGUX(IGAS) & - +NG*IUB,ITX,IPX-1) & - + WBAB*TAUTBL(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX,IPX-1) & - + WBBA*TAUTBL(IG+IGUX(IGAS) & - +NG*IUB,ITX+1,IPX-1) & - + WBBB*TAUTBL(IG+IGUX(IGAS) & - +NG*(IUB+1),ITX+1,IPX-1) - ENDIF - - TAUSUM = TRGXLK(L,KK) + TAUIPG - IF ( TAUSUM>0 ) TRGXLK(L,KK) = TAUSUM - KK = KK + 1 - ENDDO - ELSE -! IGAS=17-20 Chloro Fluoro Carbons -! ---------- --------------------- - DO IK = 1, NG - XA = WTB*(XKCFC(IK,ITX+1,IGAS) & - -XKCFC(IK,ITX,IGAS)) & - + XKCFC(IK,ITX,IGAS) - XB = WTB*(XKCFC(IK,ITX+1,IGAS) & - -XKCFC(IK,ITX,IGAS)) & - + XKCFC(IK,ITX,IGAS) - XK = WPB*(XA-XB) + XB - TAUCF = XK*UGAS - TRGXLK(L,KK) = TRGXLK(L,KK) + TAUCF - KK = KK + 1 - ENDDO - ENDIF - ENDIF - ENDDO - - -!------------------------------------------------------------------- -! H2O WINDOW ABSORPTION (2013) -!------------------------------------------------------------------- - IF ( MLGAS(1)==1 ) THEN - XK = WTB*(XKH2OW(ITX+1)-XKH2OW(ITX)) + XKH2OW(ITX) - TRGXLK(L,1) = TRGXLK(L,1) + XK*ULGAS(L,1) - ENDIF - -! CFC11 and CFC12 Window Absorption (1997) -! ---------------------------------------- - - IF ( MLGAS(17)==1 .OR. MLGAS(18)==1 ) THEN - XK = WTB*(XKCFCW(ITX+1,1)-XKCFCW(ITX,1)) & - + XKCFCW(ITX,1) - TAU11 = XK*(ULGAS(L,8)+ULGAS(L,11)) - TRGXLK(L,1) = TRGXLK(L,1) + TAU11 - ENDIF - IF ( MLGAS(19)==1 .OR. MLGAS(20)==1 ) THEN - XK = WTB*(XKCFCW(ITX+1,2)-XKCFCW(ITX,2)) & - + XKCFCW(ITX,2) - TAU12 = XK*ULGAS(L,9) - TRGXLK(L,1) = TRGXLK(L,1) + TAU12 - ENDIF - EXIT - ELSE - IPX = IPX + 1 - ENDIF - ENDDO - ENDDO - -! Optional LW up-flux correction for top 10 layers above 0.2 mb - IF ( kfpco2==4 ) THEN - CALL GET_DXTRU3_CORR(dxtru3_10,jlat,MLAT46,jday) - xtru(nl-9:nl,3) = 1.D0 + dxtru3_10(1:10) - ENDIF - - END SUBROUTINE TAUGAS - - SUBROUTINE THERML -#ifdef PLANET_PARAMS - USE CONSTANT, ONLY:KAPA ! exceptional use of external module -#endif - IMPLICIT NONE -! ------------------------------------------------------------------ -! Top-cloud Thermal Scattering Correction Control Parameters -! ---------------------------------------------------------- -! -! ECLTRA = 1.0 Scattering correction is enabled -! with KCLDEM = 1, Rigorous scattering correction is applied -! with KCLDEM = 0, Approximate scattering correction is used -! -! ECLTRA = 0.0 No scattering correction is used -! (Independent of KCLDEM value) -! -! ------------------------------------------------------------------ -! Lower Edge Temperature Interpolation -! ------------------------------------ -! TLGRAD=1.0 (Default) -! Layer-mean temperatures (TLM) supplied by GCM are used -! to define the layer edge temperature TLT (top) and TLB -! (bottom) using overall atmospheric temperature profile -! to establish temperature gradient within each layer so -! as to minimize the temperature discontinuities between -! layer edges and to conserve layer thermal energy. -! -! TLGRAD=0.0 This results in isothermal layers with TLT = TLB = TLM -! -! TLGRAD<0.0 TLT and TLB are used as specified, without any further -! adjustments. This is mainly for off-line use when the -! temperature profile (TLM,TLT,TLB) can be fully defined -! from a continuous temperature profile. -! -! NOTE: TLGRAD can also accommodate values between 0.0 and 1.0 -! -! PTLISO (Default PTLISO=2.5mb) -! Pressure level above which model layers are defined to -! be isothermal. This is appropriate for optically thin -! layers where emitted flux depends on mean temperature. -! ------------------------------------------------------------------ - REAL*8 :: PX(9) = (/1001.,973.,934.,865.,752.,603.,439.,283., & - 156./) - REAL*8 :: ALG2 = .30103D0, TAUMNL = -2.20412D0 - - REAL*8, PARAMETER :: R6 = .16666667D0, R24 = 4.1666667D-02 - REAL*8, PARAMETER :: A = 0.3825D0, B = 0.5742D0, C = 0.0433D0 - -#ifndef PLANET_PARAMS - REAL*8, PARAMETER :: KAPA = .286D0 -#endif - - REAL*8 TA, TB, TC, P1, P2, P3, P4, DT1CPT, DTHALF, CLTAUX, CLTAUS,& - CLCOSB, CTX, DT2, DT1, CTG, DG2, DG1, WT1, WT2, WT3, WT4, & - WT5, WT6, WT7, WT8, BG, DNACUM, DNBCUM, DNCCUM, TAUAG, & - TAUAP, TAUBP, TAUCP, TAUAX, TAUBX, TAUCX, XTRDL, BTOP, & - BBOT, BBAR, TX, PLBN, F, TAUA, TAUB, TAUC, BDIF, BBTA, & - BBTB, BBTC, TRANA, TRANB, TRANC, DEC, DEB, DEA, COALB1, & - COALB2, COALB3, FDNABC, UNA, UNB, UNC, FUNABC, PFW, DPF, & - CTP, DP1, DP2, TAUBG, TAUCG, DDFLUX, XTRUL, FSUM, XFSUM, & - PLL, DTAU0, TAUPLG, AP1, AP2, XTF, XTFACN - REAL*8 ENA(LX), ENB(LX), ENC(LX), TRA(LX), TRB(LX), TRC(LX) - REAL*8 DNA(LX), DNB(LX), DNC(LX), WTLB(LX), WTLT(LX) - REAL*8 RIJTCK(6,33), FDXTCK(3,33), FEMTCK(3,33), ALBTCK(3,33) - REAL*8 CLPI0(33), CLPI0K - INTEGER K, L, LL, II, ITL, ICT, IT1, IT2, IP1, IP2, ICG, IG1, IG2,& - IMOL, IPF, ICP, ITLT(LX), ITLB(LX), IP, IPX0, ITAU1, & - ITAU2, LTOPA, LCL(LX), ia, iaa, ic, iu, lvlo, lvhi, lskip,& - lcbot, nclds, icomb - -!----------------------------------------------------------------------- -! Layer edge temperature interpolation -!----------------------------------------------------------------------- - IF ( TLGRAD>=0.D0 ) THEN - TA = TLM(L1) - TB = TLM(L1+1) - P1 = PLB(L1) - P2 = PLB(L1+1) - P3 = PLB(L1+2) - DT1CPT = .5*TA*(P1**KAPA-P2**KAPA)/PL(L1)**KAPA - DTHALF = (TA-TB)*(P1-P2)/(P1-P3) - IF ( DTHALF>DT1CPT ) DTHALF = DT1CPT - TLB(L1) = TA + DTHALF*TLGRAD - TLT(L1) = TA - DTHALF*TLGRAD - DO L = L1 + 1, NL - 1 - TC = TLM(L+1) - P4 = PLB(L+2) - DTHALF = .5*((TA-TB)/(P1-P3)+(TB-TC)/(P2-P4))*(P2-P3)*TLGRAD - TLB(L) = TB + DTHALF - TLT(L) = TB - DTHALF - TA = TB - TB = TC - P1 = P2 - P2 = P3 - P3 = P4 - ENDDO - DTHALF = (TA-TB)*(P2-P3)/(P1-P3)*TLGRAD - TLB(NL) = TC + DTHALF - TLT(NL) = TC - DTHALF - DO L = NL, L1, -1 - IF ( PLB(L)>PTLISO ) EXIT - TLT(L) = TLM(L) - TLB(L) = TLM(L) - ENDDO - ENDIF - TLB(NL+1) = TLT(NL) - -! ------------------------------------------------------------------ -! weight assignments for Planck function interpolation -! (Effective range (K) is from TK = planck_tmin to TK = planck_tmax) -! ------------------------------------------------------------------ - - DO L = L1, NL - ITLB(L) = TLB(L) - WTLB(L) = TLB(L) - ITLB(L) - IF ( ITLB(L)planck_tmax-1 ) ITLB(L) = planck_tmax - 1 - ITLT(L) = TLT(L) - WTLT(L) = TLT(L) - ITLT(L) - IF ( ITLT(L)planck_tmax-1 ) ITLT(L) = planck_tmax - 1 - ENDDO - - IF ( LTOPCL/=0 ) THEN - - DO K = 1, 33 - CLTAUX = TXCTPG(K) + TRGXLK(LTOPCL,K) + 1D-10 - CLTAUS = TSCTPG(K) - CLCOSB = TGCTPG(K) - CLPI0K = CLTAUS*ECLTRA/CLTAUX - CLPI0(K) = CLPI0K - CTX = CLTAUX*10.D0 - IF ( CLTAUX>=3.D0 ) THEN - CTX = CLTAUX*2 + 24 - IF ( CTX>47.999999D0 ) CTX = 47.999999D0 - ENDIF - ICT = CTX - DT2 = CTX - ICT - DT1 = 1.D0 - DT2 - IT1 = ICT + 1 - IT2 = ICT + 2 - CTP = CLPI0K*20.D0 - ICP = CTP - DP2 = CTP - ICP - DP1 = 1.D0 - DP2 - IP1 = ICP + 1 - IP2 = ICP + 2 - CTG = CLCOSB*20.D0 - ICG = CTG - DG2 = CTG - ICG - DG1 = 1.D0 - DG2 - IG1 = ICG + 1 - IG2 = ICG + 2 - WT1 = DT1*DP1*DG1 - WT2 = DT2*DP1*DG1 - WT3 = DT2*DP2*DG1 - WT4 = DT1*DP2*DG1 - WT5 = DT1*DP1*DG2 - WT6 = DT2*DP1*DG2 - WT7 = DT2*DP2*DG2 - WT8 = DT1*DP2*DG2 - RIJTCK(:,K) = WT1*RIJTPG(:,IT1,IP1,IG1) & - + WT2*RIJTPG(:,IT2,IP1,IG1) & - + WT3*RIJTPG(:,IT2,IP2,IG1) & - + WT4*RIJTPG(:,IT1,IP2,IG1) & - + WT5*RIJTPG(:,IT1,IP1,IG2) & - + WT6*RIJTPG(:,IT2,IP1,IG2) & - + WT7*RIJTPG(:,IT2,IP2,IG2) & - + WT8*RIJTPG(:,IT1,IP2,IG2) ! 1:6 - FEMTCK(:,K) = WT1*FEMTPG(:,IT1,IP1,IG1) & - + WT2*FEMTPG(:,IT2,IP1,IG1) & - + WT3*FEMTPG(:,IT2,IP2,IG1) & - + WT4*FEMTPG(:,IT1,IP2,IG1) & - + WT5*FEMTPG(:,IT1,IP1,IG2) & - + WT6*FEMTPG(:,IT2,IP1,IG2) & - + WT7*FEMTPG(:,IT2,IP2,IG2) & - + WT8*FEMTPG(:,IT1,IP2,IG2) ! 1:3 - FDXTCK(:,K) = WT1*FDXTPG(:,IT1,IP1,IG1) & - + WT2*FDXTPG(:,IT2,IP1,IG1) & - + WT3*FDXTPG(:,IT2,IP2,IG1) & - + WT4*FDXTPG(:,IT1,IP2,IG1) & - + WT5*FDXTPG(:,IT1,IP1,IG2) & - + WT6*FDXTPG(:,IT2,IP1,IG2) & - + WT7*FDXTPG(:,IT2,IP2,IG2) & - + WT8*FDXTPG(:,IT1,IP2,IG2) - ENDDO - ENDIF - - TRDFLB(:) = 0.D0 - TRUFLB(:) = 0.D0 - - BG = BGFEMT(1) - TOTLZF(1:3) = 0.D0 -!sl TRSLTS=0.D0 -!sl TRSLTG=0.D0 -!sl TRSLBS=0.D0 - -! ------------------------------------------------------------------ -! LOOP OVER K-BANDS -! ------------------------------------------------------------------ - K = 0 - IMOL = 0 - 200 DO - K = K + 1 - IF ( K>33 ) THEN - - TRNFLB(L1:NL+1) = TRUFLB(L1:NL+1) - TRDFLB(L1:NL+1) - TRFCRL(L1:NL) = TRNFLB(L1+1:NL+1) - TRNFLB(L1:NL) - -!**** Window region and spectr. integrated total flux diagnostics - DO II = 0, 3 - IF ( II>0 ) THEN - PFW = TOTLZF(II) - IF ( PFW<1 ) PFW = 1 - IF ( PFW>899.999D0 ) PFW = 899.999D0 - IPF = PFW - TOTLZT(II) = TKPFT(IPF) + (PFW-IPF) & - *(TKPFT(IPF+1)-TKPFT(IPF)) - - PFW = 10*WINDZF(II) - ELSE - PFW = 10*TRUFTW - ENDIF - IF ( PFW<1.0001D-2 ) PFW = 1.0001D-2 - IF ( PFW>719.999D0 ) PFW = 719.999D0 - IPF = PFW - IF ( PFW<1 ) THEN - PFW = 100.*PFW - IPF = PFW - DPF = PFW - IPF ! IPF= 1- 99 - ELSEIF ( PFW<10 ) THEN - PFW = 10.*PFW - IPF = PFW - DPF = PFW - IPF - IPF = IPF + 90 ! IPF=100-189 - ELSE - IPF = PFW - DPF = PFW - IPF - IPF = IPF + 180 ! IPF=190-899 - ENDIF - IF ( II>0 ) THEN - WINDZT(II) = TKPFW(IPF) & - + DPF*(TKPFW(IPF+1)-TKPFW(IPF)) - ELSE - BTEMPW = TKPFW(IPF) + DPF*(TKPFW(IPF+1)-TKPFW(IPF)) - ENDIF - ENDDO - GOTO 99999 - ELSE - BG = BGFEMT(K) - IF ( K>1 .AND. K<14 ) IMOL = 1 - IF ( K>13 .AND. K<26 ) IMOL = 2 - IF ( K>25 ) IMOL = 3 - DFLB(NL+1,K) = 0.D0 - DNACUM = 0.D0 - DNBCUM = 0.D0 - DNCCUM = 0.D0 -!**** Find top layer with absorbers: LtopA - DO L = NL, L1, -1 - LTOPA = L - TAUAG = TRGXLK(L,K) - TAUAP = TRCALK(L,K) + TRAALK(L,K) + TRBALK(L,K) & - + TRDALK(L,K) + TRVALK(L,K) - TAUAX = TAUAG + TAUAP - IF ( TAUAX>1.D-06 ) GOTO 211 - DFLB(L,K) = 0.D0 - ENA(L) = 0.D0 - DNA(L) = 0.D0 - TRA(L) = 1.D0 - ENB(L) = 0.D0 - DNB(L) = 0.D0 - TRB(L) = 1.D0 - ENC(L) = 0.D0 - DNC(L) = 0.D0 - TRC(L) = 1.D0 - ENDDO - UFLB(L1:NL+1,K) = BG ! no absorbers in whole column - TRUFLB(L1:NL+1) = TRUFLB(L1:NL+1) + BG - TOTLZF(1) = TOTLZF(1) + BG - TOTLZF(2) = TOTLZF(2) + BG - TOTLZF(3) = TOTLZF(3) + BG - ENDIF - ENDDO - - 211 FSUM = 0. - XFSUM = 0. - XTFACN = 0. - IPX0 = 9 -! ------------------------------------------------------------------ -! DOWNWARD FLUX COMPUTATION -! ------------------------------------------------------------------ - DO L = LTOPA, L1, -1 - BTOP = PLANCK(ITLT(L),K) & - - (PLANCK(ITLT(L),K)-PLANCK(ITLT(L)+1,K))*WTLT(L) - BBOT = PLANCK(ITLB(L),K) & - - (PLANCK(ITLB(L),K)-PLANCK(ITLB(L)+1,K))*WTLB(L) - TAUAG = TRGXLK(L,K) - TAUAP = TRCALK(L,K) + TRAALK(L,K) + TRBALK(L,K) + TRDALK(L,K) & - + TRVALK(L,K) - TAUAX = TAUAG + TAUAP - IF ( TAUAP>=.003 ) THEN - PLL = PL(L) - DO IP = IPX0, 1, -1 - IP1 = IP - IF ( PLL10 ) ITAU1 = 10 - ITAU2 = ITAU1 + 1 - DT1 = DTAU0 - (ITAU1-1)*ALG2 - DT2 = ALG2 - DT1 - AP1 = (XTFAC(ITAU2,IP1)*DT1+XTFAC(ITAU1,IP1)*DT2)/ALG2 - AP2 = (XTFAC(ITAU2,IP2)*DT1+XTFAC(ITAU1,IP2)*DT2)/ALG2 - XTF = (AP2*(PLL-PX(IP1))+AP1*(PX(IP2)-PLL)) & - /(PX(IP2)-PX(IP1)) - FSUM = FSUM + XTF/(1.+1.75*XFSUM**2)**2 - XTFACN = FSUM - IF ( XTFACN>1. ) XTFACN = 1. - IF ( XTFACN<0. ) XTFACN = 0. - XFSUM = XFSUM + XTF - ENDIF - - XTRDL = XTRD(L,IMOL+1) - XTRDL = XTRDL + XTFACN*(1.-XTRDL) - -! Optically thin limit emission/transmission approximation -! -------------------------------------------------------- - - IF ( TAUAX>=1.D-04 ) THEN - -! TAUB absorber-dependent extinction path adjustment -! -------------------------------------------------- - - PLBN = PLB(L) - ICOMB = 0 - IF ( TAUAG>TAUAP ) THEN - ICOMB = 1 - TAUAG = TAUAX - ENDIF - TAUBG = TAUAG + TAUAG - TAUCG = 10.D0*TAUAG - - F = 1 - IF ( IMOL==3 .AND. PLBN>500 .AND. TAUAG>.05D0 .AND. & - TAUAG<.25 ) THEN - F = 23.71D0*TAUAG**2 - 7.113D0*TAUAG + 1.296D0 - GOTO 221 - ENDIF - - IF ( TAUAG>.1D0 ) THEN - IF ( IMOL==1 ) THEN - IF ( PLBN>250.D0 ) THEN - F = .761D0 - IF ( TAUAG<3.D0 ) F = .92D0 - .053D0*TAUAG - IF ( TAUAG<.2D0 ) F = 1.091D0 - .906D0*TAUAG - ELSE - F = .718D0 - IF ( TAUAG<2.5D0 ) F = .90D0 - .073D0*TAUAG - IF ( TAUAG<.2D0 ) F = 1.115D0 - 1.146D0*TAUAG - ENDIF - ELSEIF ( IMOL==2 ) THEN - IF ( PLBN>250.D0 ) THEN - F = .590D0 - IF ( TAUAG<3.5D0 ) F = .93D0 - .097D0*TAUAG - IF ( TAUAG<.2D0 ) F = 1.089D0 - .894D0*TAUAG - ELSE - F = .703D0 - IF ( TAUAG<3.5D0 ) F = .92D0 - .062D0*TAUAG - IF ( TAUAG<.2D0 ) F = 1.092D0 - .924D0*TAUAG - ENDIF - ELSEIF ( IMOL==3 ) THEN - IF ( PLBN>250.D0 ) THEN - F = .982D0 - IF ( TAUAG<.5D0 ) F = .99D0 - .016D0*TAUAG - IF ( TAUAG<.2D0 ) F = 1.013D0 - .132D0*TAUAG - ELSE - F = .748D0 - IF ( TAUAG<3.7D0 ) F = .97D0 - .060D0*TAUAG - IF ( TAUAG<.2D0 ) F = 1.042D0 - .420D0*TAUAG - ENDIF - ENDIF - ENDIF - 221 TAUBG = TAUBG*F - -! TAUC absorber-dependent extinction path adjustment -! -------------------------------------------------- - F = 1 - IF ( IMOL==3 .AND. PLBN>500 .AND. TAUAG>.01D0 .AND. & - TAUAG<.25 ) THEN - F = 26.14D0*TAUAG**2 - 6.796D0*TAUAG + 1.065D0 - GOTO 222 - ENDIF - - IF ( TAUAG>.01D0 ) THEN - IF ( IMOL==1 ) THEN - IF ( PLBN>250.D0 ) THEN - F = .712D0 - IF ( TAUAG<.37D0 ) F = .96D0 - .67D0*TAUAG - IF ( TAUAG<.02D0 ) F = 1.053D0 - 5.34D0*TAUAG - ELSE - F = .536D0 - IF ( TAUAG<.47D0 ) F = .87D0 - .71D0*TAUAG - IF ( TAUAG<.02D0 ) F = 1.144D0 - 14.42D0*TAUAG - ENDIF - ELSEIF ( IMOL==2 ) THEN - IF ( PLBN>250.D0 ) THEN - F = .710D0 - IF ( TAUAG<.75D0 ) F = .95D0 - .32D0*TAUAG - IF ( TAUAG<.02D0 ) F = 1.056D0 - 5.64D0*TAUAG - ELSE - F = .487D0 - IF ( TAUAG<.70D0 ) F = .90D0 - .59D0*TAUAG - IF ( TAUAG<.02D0 ) F = 1.112D0 - 11.18D0*TAUAG - ENDIF - ELSEIF ( IMOL==3 ) THEN - IF ( PLBN>250.D0 ) THEN - F = .961D0 - IF ( TAUAG<.5D0 ) F = .98D0 - .039D0*TAUAG - IF ( TAUAG<.02D0 ) F = 1.021D0 - 2.08D0*TAUAG - ELSE - F = .777D0 - IF ( TAUAG<.70D0 ) F = .98D0 - .29D0*TAUAG - IF ( TAUAG<.02D0 ) F = 1.026D0 - 2.58D0*TAUAG - ENDIF - ENDIF - ENDIF - 222 TAUCG = TAUCG*F - - IF ( ICOMB==0 ) THEN - TAUBP = TAUAP + TAUAP - TAUCP = 10.D0*TAUAP - TAUA = TAUAG + TAUAP - TAUB = TAUBG + TAUBP - TAUC = TAUCG + TAUCP - ELSE - TAUA = TAUAG - TAUB = TAUBG - TAUC = TAUCG - ENDIF - - IF ( L==LTOPCL .AND. KCLDEM==1 ) THEN - -! --------------------------------------------- -! Top-cloud multiple scattering corrections for -! emitted, transmitted, and reflected radiances -! and fluxes at the top-cloud (L=LTOPCL) level. -! --------------------------------------------- - - IF ( ICOMB==1 ) THEN - TAUBP = TAUAP*(TAUBG/TAUAG) - TAUCP = TAUAP*(TAUCG/TAUAG) - TAUBG = TRGXLK(L,K)*(TAUBG/TAUAG) - TAUCG = TRGXLK(L,K)*(TAUCG/TAUAG) - TAUAG = TAUAG - TAUAP - ENDIF - TRA(L) = EXP(-TAUAG-TAUAP*FDXTCK(3,K)) - TRB(L) = EXP(-TAUBG-TAUBP*FDXTCK(2,K)) - TRC(L) = EXP(-TAUCG-TAUCP*FDXTCK(1,K)) - DEC = C*DNCCUM*RIJTCK(1,K) + B*DNBCUM*RIJTCK(2,K) & - + A*DNACUM*RIJTCK(3,K) - DEB = C*DNCCUM*RIJTCK(2,K) + B*DNBCUM*RIJTCK(4,K) & - + A*DNACUM*RIJTCK(5,K) - DEA = C*DNCCUM*RIJTCK(3,K) + B*DNBCUM*RIJTCK(5,K) & - + A*DNACUM*RIJTCK(6,K) - ALBTCK(1,K) = C*RIJTCK(1,K) + B*RIJTCK(2,K) & - + A*RIJTCK(3,K) - ALBTCK(2,K) = C*RIJTCK(2,K) + B*RIJTCK(4,K) & - + A*RIJTCK(5,K) - ALBTCK(3,K) = C*RIJTCK(3,K) + B*RIJTCK(5,K) & - + A*RIJTCK(6,K) - COALB1 = 1.D0 - ALBTCK(1,K) - COALB2 = 1.D0 - ALBTCK(2,K) - COALB3 = 1.D0 - ALBTCK(3,K) - TAUA = TAUAG + TAUAP*FEMTCK(3,K) - TAUB = TAUBG + TAUBP*FEMTCK(2,K) - TAUC = TAUCG + TAUCP*FEMTCK(1,K) - TRANA = EXP(-TAUA) - TRANB = EXP(-TAUB) - TRANC = EXP(-TAUC) - BDIF = BBOT - BTOP - BBTA = BDIF/TAUA - BBTB = BDIF/TAUB - BBTC = BDIF/TAUC - ENA(L) = (BTOP+BBTA-(BBOT+BBTA)*TRANA)*COALB3 - DNA(L) = (BBOT-BBTA-(BTOP-BBTA)*TRANA)*COALB3 - TX = TRA(L)*XTRDL - ! ; if(TX > 1) TX=1 - DNACUM = DNACUM*TX + DNA(L) - ENB(L) = (BTOP+BBTB-(BBOT+BBTB)*TRANB)*COALB2 - DNB(L) = (BBOT-BBTB-(BTOP-BBTB)*TRANB)*COALB2 - TX = TRB(L)*XTRDL - ! ; if(TX > 1) TX=1 - DNBCUM = DNBCUM*TX + DNB(L) - ENC(L) = (BTOP+BBTC-(BBOT+BBTC)*TRANC)*COALB1 - DNC(L) = (BBOT-BBTC-(BTOP-BBTC)*TRANC)*COALB1 - TX = TRC(L)*XTRDL - ! ; if(TX > 1) TX=1 - DNCCUM = DNCCUM*TX + DNC(L) - ENC(L) = ENC(L) + DEC - ENB(L) = ENB(L) + DEB - ENA(L) = ENA(L) + DEA - ELSE - - BDIF = BBOT - BTOP - BBTA = BDIF/TAUA - BBTB = BDIF/TAUB - BBTC = BDIF/TAUC - -! Optically thick limit non-scattering emission approximation -! ----------------------------------------------------------- - - IF ( TAUA>9.D0 ) THEN - TRA(L) = 0.D0 - TRB(L) = 0.D0 - TRC(L) = 0.D0 - ENA(L) = BTOP + BBTA - ENB(L) = BTOP + BBTB - ENC(L) = BTOP + BBTC - DNA(L) = BBOT - BBTA - DNB(L) = BBOT - BBTB - DNC(L) = BBOT - BBTC - DNACUM = BBOT - BBTA - DNBCUM = BBOT - BBTB - DNCCUM = BBOT - BBTC - GOTO 230 - ENDIF - - IF ( TAUA<0.5D0 ) THEN - TRANA = 1 - TAUA + (.5-R6*TAUA+R24*(TAUA*TAUA)) & - *(TAUA*TAUA) - ELSE - TRANA = EXP(-TAUA) - ENDIF - IF ( TAUB<0.5D0 ) THEN - TRANB = 1 - TAUB + (.5-R6*TAUB+R24*(TAUB*TAUB)) & - *(TAUB*TAUB) - ELSE - TRANB = EXP(-TAUB) - ENDIF - IF ( TAUC<0.5D0 ) THEN - TRANC = 1 - TAUC + (.5-R6*TAUC+R24*(TAUC*TAUC)) & - *(TAUC*TAUC) - ELSE - TRANC = EXP(-TAUC) - ENDIF - - TRA(L) = TRANA - ENA(L) = BTOP + BBTA - (BBOT+BBTA)*TRANA - DNA(L) = BBOT - BBTA - (BTOP-BBTA)*TRANA - TX = TRANA*XTRDL - ! ; if(TX > 1) TX=1 - DNACUM = DNACUM*TX + DNA(L) - TRB(L) = TRANB - ENB(L) = BTOP + BBTB - (BBOT+BBTB)*TRANB - DNB(L) = BBOT - BBTB - (BTOP-BBTB)*TRANB - TX = TRANB*XTRDL - ! ; if(TX > 1) TX=1 - DNBCUM = DNBCUM*TX + DNB(L) - TRC(L) = TRANC - ENC(L) = BTOP + BBTC - (BBOT+BBTC)*TRANC - DNC(L) = BBOT - BBTC - (BTOP-BBTC)*TRANC - TX = TRANC*XTRDL - ! ; if(TX > 1) TX=1 - DNCCUM = DNCCUM*TX + DNC(L) - ENDIF - ELSE - TAUBX = TAUAX + TAUAX - TAUCX = 10.D0*TAUAX - BBAR = 0.5D0*(BTOP+BBOT) - TRA(L) = 1.D0 - TAUAX - ENA(L) = BBAR*TAUAX - DNA(L) = ENA(L) - TX = TRA(L)*XTRDL - ! ; if(TX > 1) TX=1 - DNACUM = DNACUM*TX + DNA(L) - TRB(L) = 1.D0 - TAUBX - ENB(L) = BBAR*TAUBX - DNB(L) = ENB(L) - TX = TRB(L)*XTRDL - ! ; if(TX > 1) TX=1 - DNBCUM = DNBCUM*TX + DNB(L) - TRC(L) = 1.D0 - TAUCX - ENC(L) = BBAR*TAUCX - DNC(L) = ENC(L) - TX = TRC(L)*XTRDL - ! ; if(TX > 1) TX=1 - DNCCUM = DNCCUM*TX + DNC(L) - ENDIF - 230 FDNABC = A*DNACUM + B*DNBCUM + C*DNCCUM - TRDFLB(L) = TRDFLB(L) + FDNABC - DFLB(L,K) = FDNABC - ENDDO - -! Old form of scattering correction is skipped when KCLDEM=1 -! ---------------------------------------------------------- - - IF ( KCLDEM==0 .AND. LTOPCL>0 ) THEN - ENA(LTOPCL) = ENA(LTOPCL)*(1-TRCTCA(K)) + TRCTCA(K) & - *DFLB(LTOPCL+1,K) - ENB(LTOPCL) = ENB(LTOPCL)*(1-TRCTCA(K)) + TRCTCA(K) & - *DFLB(LTOPCL+1,K) - ENC(LTOPCL) = ENC(LTOPCL)*(1-TRCTCA(K)) + TRCTCA(K) & - *DFLB(LTOPCL+1,K) - ENDIF - -!sl ------------------------------------------------------------------ -!sl SURFACE LAYER FLUX COMPUTATION -!sl with TAUSL,FTAUSL=0 defaults, surface layer calculation is skipped -!sl ------------------------------------------------------------------ - - DFSL(K) = FDNABC -!sl TAUA=TAUSL(K)+FTAUSL(K) -!sl if (TAUA > 1.D-06) GO TO 24 - BG = BG + FDNABC*TRGALB(K) - UNA = BG - UNB = BG - UNC = BG - FUNABC = BG -!sl GO TO 245 -!sl24 CONTINUE -!sl ITS=TSL -!sl WTS=TSL-ITS -!sl WTS1=1-WTS -!sl BS = PLANCK(ITS,K)*WTS1 + PLANCK(ITS+1,K)*WTS -!sl TA=EXP(-TAUA) -!sl TB=TA*TA -!sl TC=(TB*TB*TA)**2 -!sl DNA(1)=(DNA(1)-BS)*TA+BS -!sl DNB(1)=(DNB(1)-BS)*TB+BS -!sl DNC(1)=(DNC(1)-BS)*TC+BS -!sl FDNABC=A*DNA(1)+B*DNB(1)+C*DNC(1) -!sl BG=BGFEMT(K)+FDNABC*TRGALB(K) -!sl UNA=(BG-BS)*TA+BS -!sl UNB=(BG-BS)*TB+BS -!sl UNC=(BG-BS)*TC+BS -!sl FUNABC=A*UNA+B*UNB+C*UNC -!sl BSP = PLANCK(ITS+1,K)*WTS1 + PLANCK(ITS+2,K)*WTS -!sl BSM = PLANCK(ITS-1,K)*WTS1 + PLANCK(ITS ,K)*WTS -!sl SLABS=1.D0-A*TA-B*TB-C*TC -!sl TRSLTS=TRSLTS+(BSP-BSM)*SLABS -!sl TRSLTG=TRSLTG+BGFEMD(K)*SLABS -!sl TRSLBS=TRSLBS+BS*SLABS - -! ------------------------------------------------------------------ -! UPWARD FLUX COMPUTATION -! ------------------------------------------------------------------ - - DO L = L1, NL - TRUFLB(L) = TRUFLB(L) + FUNABC - UFLB(L,K) = FUNABC - -! ---------------------------------------------------------------- -! At top-cloud level, find component of upwelling flux reflected -! downward by cloud bottom and add to downwelling flux below cloud -! ---------------------------------------------------------------- - - IF ( L==LTOPCL .AND. KCLDEM==1 ) THEN - DEC = C*UNC*RIJTCK(1,K) + B*UNB*RIJTCK(2,K) & - + A*UNA*RIJTCK(3,K) - DEB = C*UNC*RIJTCK(2,K) + B*UNB*RIJTCK(4,K) & - + A*UNA*RIJTCK(5,K) - DEA = C*UNC*RIJTCK(3,K) + B*UNB*RIJTCK(5,K) & - + A*UNA*RIJTCK(6,K) - DO LL = L, L1, -1 - DNA(LL) = DNA(LL) + DEA - DNB(LL) = DNB(LL) + DEB - DNC(LL) = DNC(LL) + DEC - DDFLUX = A*DEA + B*DEB + C*DEC - TRDFLB(LL) = TRDFLB(LL) + DDFLUX - DFLB(LL,K) = DFLB(LL,K) + DDFLUX - IF ( LL==L1 ) EXIT - ! LL-loop - DEA = DEA*TRA(LL-1) - DEB = DEB*TRB(LL-1) - DEC = DEC*TRC(LL-1) - ENDDO - ENDIF - XTRUL = XTRU(L,IMOL+1) - TX = TRA(L)*XTRUL - ! ; if(TX > 1) TX=1 - UNA = UNA*TX + ENA(L) - TX = TRB(L)*XTRUL - ! ; if(TX > 1) TX=1 - UNB = UNB*TX + ENB(L) - TX = TRC(L)*XTRUL - ! ; if(TX > 1) TX=1 - UNC = UNC*TX + ENC(L) - FUNABC = A*UNA + B*UNB + C*UNC - ENDDO - - IF ( K==1 ) THEN - TRUFTW = FUNABC - TRDFGW = TRDFLB(1) - TRUFGW = BG - WINDZF(1) = UNA - WINDZF(2) = UNB - WINDZF(3) = UNC - ENDIF - - TRUFLB(NL+1) = TRUFLB(NL+1) + FUNABC - UFLB(NL+1,K) = FUNABC - UFSL(K) = UFLB(1,K) - TOTLZF(1) = TOTLZF(1) + UNA - TOTLZF(2) = TOTLZF(2) + UNB - TOTLZF(3) = TOTLZF(3) + UNC - - GOTO 200 ! next K - -99999 END SUBROUTINE THERML - - SUBROUTINE SOLAR0 - IMPLICIT NONE - - INTEGER, PARAMETER, DIMENSION(17) & - :: NMKWAV = (/200,360,770,795,805,& - 810,860,1250,1500,1740,2200,3000, & - 3400,3600,3800,4000,9999/) - INTEGER, PARAMETER, DIMENSION(16) & - :: LORDER = (/15,14,8,7,6,5,13,12,& - 4,3,2,1,11,10,9,16/) - INTEGER I - - DO I = 1, 30 - DBLN(I) = 2**I - ENDDO - - NORDER(1:16) = LORDER(1:16) - NMWAVA(1:16) = NMKWAV(1:16) - NMWAVB(1:16) = NMKWAV(2:17) - - TCLMIN = MIN(TAUIC0,TAUWC0) - - CALL SETO2A - - END SUBROUTINE SOLAR0 - - SUBROUTINE SOLARM - IMPLICIT NONE -! ------------------------------------------------------------------ -! SOLARM Returns: -! SRDFLB Solar downward flux at layer bottom edge -! SRUFLB Solar upward flux at layer bottom edge -! SRNFLB Solar net downward flux (in Watts/m**2) -! SRFHRL Solar heating rate/layer (in Watts/m**2) -! FSRNFG Solar flux abs at ground by surface-type -! (see explanatory note at end of SOLARM) -! Also: -! TOA: SRIVIS SROVIS PLAVIS SRINIR SRONIR PLANIR -! BOA: SRDVIS SRUVIS ALBVIS SRDNIR SRUNIR ALBNIR -! ATM: SRTVIS SRRVIS SRAVIS SRTNIR SRRNIR SRANIR -! SRXVIS SRXNIR (Direct beam only at ground) -! -! Spectral: (by k-distribution/pseudo-spectral) breakdown: -! SKDFLB Solar downward flux at layer bottom edge -! SKUFLB Solar upward flux at layer bottom edge -! SKNFLB Solar net downward flux (in Watts/m**2) -! SKFHRL Solar heating rate/layer (in Watts/m**2) -! -! SRKALB Planetary albedo (by spectral breakdown) -! SRKINC Incident fluxedo (by spectral breakdown) -! SRKGAX Direct k-d flux absorbed by ground-type -! SRKGAD Diffuse k-d flux absorbed by ground-type -! ------------------------------------------------------------------ -! Remarks: -! NORMS0=1 Incident (TOA) Solar flux normalized to equal S0 -! (COSZ dependence included in calculated results) -! The returned solar fluxes have to be multiplied -! by COSZ to yield actual atmospheric heating rate -! -! NMKWAV Spectral/k-distribution subdivisions are nominal -! (due to spectral trading of absorption features) -! -! VIS Designates solar visible wavelengths ( <770nm) -! NIR Designates solar near-IR wavelengths (770> nm) -! VIS comprises .53 of S0, NIR comprises .47 of S0 -! ------------------------------------------------------------------ -! -! ------------------------------------------------------------------ -! Fractional solar flux k-distribution/pseudo-spectral intervals -! -! KSLAM= 1 1 2 2 5 5 5 5 -! K= 1 2 3 4 5 6 7 8 -! DATA DKS0/ .010, .030, .040, .040, .040, .002, .004, .013, -! KSLAM= 1 1 1 3 4 6 6 1 -! K= 9 10 11 12 13 14 15 16 -! + .002, .003, .003, .072, .200, .480, .050, .011/ -! -! ------------------------------------------------------------------ -! The nominal spectral order for k-dist/pseudo-spectral intervals is -! (WavA and WavB designate approximate spectral interval boundaries) -! -! L= 12 11 10 9 6 5 4 3 -! WavA (nm)= 3000 2200 1740 1500 810 805 795 770 -! WavB (nm)= 3400 3000 2200 1740 860 810 805 795 -! K= 1 2 3 4 5 6 7 8 -! DATA DKS0/ .010, .030, .040, .040, .040, .002, .004, .013, -! -! L= 15 14 13 8 7 2 1 16 -! WavA (nm)= 3800 3500 3400 1250 860 360 200 4000 -! WavB (nm)= 4000 3800 3600 1500 1250 770 360 9999 -! K= 9 10 11 12 13 14 15 16 -! + .002, .003, .003, .072, .200, .480, .050, .011/ -! -! ------------------------------------------------------------------ -! 6 spectral intervals overlap the 16 solar k-distribution intervals -! -! Cloud and aerosol Mie scattering parameters (also surface albedos) -! are averaged over these spectral intervals. These intervals are in -! reverse spectral order. Thus spectral interval 6 refers to visible -! (VIS) wavelengths, intervals 1-5 refer to nearIR (NIR) wavelengths -! KSLAM designates the spectral interval of first 14 k-distributions -! (K=15 for UV ozone absorption refers to (VIS) spectral interval 6) -! (K=16 represents strong absorbing spectral regions via interval 1) -! -! The nominal Mie scattering spectral band subdivisions are: -! -! -------------NIR------------ VIS -! L= 1 2 3 4 5 6 -! WavA (nm)= 2200 1500 1250 860 770 300 -! WavB (nm)= 4000 2200 1500 1250 860 770 -! -! ------------------------------------------------------------------ - - REAL*8 COLEXT(6), COLSCT(6), COLGCB(6) ! ,ALLGCB(6) - -! ------------------------------------------- -! NO2, O3 Chappuis Band, Rayleigh, parameters -! ------------------------------------------- - REAL*8, PARAMETER :: XCMNO2 = 5.465D0, XCMO3 = .0399623D0 - REAL*8, PARAMETER :: SIGMA_RAY = 4.4028450689125004D-07 -! Rayleigh scattering cross-section [m2/mol] - REAL*8 RNB(LX), RNX(LX), TNB(LX), TNX(LX), XNB(LX), XNX(LX) - REAL*8 SRB(LX), SRX(LX), VRU(LX+1), VRD(LX+1), FAC(LX+1) - REAL*8 AO3D(LX), AO3U(LX), AO3X(LX) - REAL*8 S0COSZ, COSMAG, SECZ, TAURAY, RTAU, SUMEXT, COLPFG, SURFBB,& - TAUSBB, ALLTAU, TAULAY, GCBLAY, RTAUL, DKS0X, RBNB, RBNX, & - RCNB, RCNX, TLN, PLN, ULN, TERMA, TERMB, TAU1, TAU, PIZERO,& - PR, PT, DBLS, XANB, XANX, TANB, TANX, XXT, RASB, RASX, & - BNORM, XNORM, RARB, RARX, XATB, DENOM, DB, DX, UB, UX, & - RBXTOA, ATOPX, ATOPD, O3CMX, O3CMD, SUMSCT, SUMGCB, XXG, & - SURX, PFF, XATC, XBNB, XBNX, TBNB, TBNX, XBTB, ABOTX, & - ABOTD, AO3UXN, AO3UDN, SRKA16, DKS0XX, TRNC, CLX, TRNU, & - TRN1, TRN2, TRN3, TAUG, TAU2, TAU3, S0VIS, S0NIR, SGPG - INTEGER I, K, KK, L, N, NN, KLAM, NDBLS - REAL*8 :: WVCOL, ZWPATH, ALPH, BETA, FACK12, ROOT, PTROOT, TAUK,& - FACK13 - - S0COSZ = S0 - IF ( NORMS0==0 ) S0COSZ = S0*COSZ - - SRDFLB(L1:NL+1) = 0 - SRUFLB(L1:NL+1) = 0 - SRNFLB(L1:NL+1) = 0 - SRFHRL(L1:NL) = 0 - - SKDFLB(L1:NL+1,16) = 0 - SKUFLB(L1:NL+1,16) = 0 - - SRKALB(1:16) = 0.D0 ! for WRITER only - dblext = 0. - dblsct = 0. - dblgcb = 0. - dblpi0 = 0. ! for writer only - skdflb = 0. - sknflb = 0. - skuflb = 0. ! for writer only - skfhrl = 0. - srkgax = 0. - srkgad = 0. ! for writer only - -! TOA solar flux VIS/NIR subdivision -! (incident, outgoing, plane albedo) -! ---------------------------------- - SRIVIS = 0.D0 - SROVIS = 0.D0 - PLAVIS = 1.D0 - SRINIR = 0.D0 - SRONIR = 0.D0 - PLANIR = 1.D0 -! BOA solar flux VIS/NIR subdivision -! (incident, upward, surface albedo) -! ---------------------------------- - SRDVIS = 0.D0 - SRUVIS = 0.D0 - ALBVIS = 1.D0 - SRDNIR = 0.D0 - SRUNIR = 0.D0 - ALBNIR = 1.D0 -! Fractional atmos only flux VIS/NIR subdivision -! (fractions reflected, transmitted, absorbed) -! ---------------------------------------------- - SRRVIS = 1.D0 - SRTVIS = 0.D0 - SRAVIS = 0.D0 - SRRNIR = 0.D0 - SRTNIR = 0.D0 - SRANIR = 0.D0 -! Direct beam, fractional S0 VIS/NIR subdivision -! ---------------------------------------------- - SRXVIS = 0.D0 - SRXNIR = 0.D0 -! Ground surface absorbed solar flux subdivision -! according to 4 fractional surface-type albedos -! ---------------------------------------------- - FSRNFG(1:4) = 0 - - IF ( COSZ<0.001D0 ) RETURN - COSMAG = 35.D0/SQRT(1224.D0*COSZ*COSZ+1.D0) - SECZ = 1.D0/COSZ - -! Compute Rayleigh optical depth, still missing dP in units of mbar - TAURAY = SIGMA_RAY/(GRAV*MAIR*1D-3)*1D+2*FRAYLE - - DO K = 1, 6 - RTAU = 1.D-10 - IF ( K==6 ) RTAU = TAURAY - COLEXT(K) = 0.D0 - COLSCT(K) = 0.D0 - COLGCB(K) = 0.D0 - DO L = L1, NL - RTAUL = RTAU*(PLB(L)-PLB(L+1)) - SUMEXT = RTAUL + SRCEXT(L,K) + SRAEXT(L,K) + SRBEXT(L,K) & - + SRDEXT(L,K) + SRVEXT(L,K) - SUMSCT = RTAUL + SRCSCT(L,K) + SRASCT(L,K) + SRBSCT(L,K) & - + SRDSCT(L,K) + SRVSCT(L,K) - SUMGCB = SRCSCT(L,K)*SRCGCB(L,K) + SRASCT(L,K)*SRAGCB(L,K) & - + SRBSCT(L,K)*SRBGCB(L,K) + SRDSCT(L,K)*SRDGCB(L,K)& - + SRVSCT(L,K)*SRVGCB(L,K) - DBLEXT(L,K) = SUMEXT - DBLSCT(L,K) = SUMSCT - DBLGCB(L,K) = SUMGCB/(SUMSCT+1.D-10) - DBLPI0(L,K) = SUMSCT/(SUMEXT+1.D-10) - COLEXT(K) = COLEXT(K) + DBLEXT(L,K) - COLSCT(K) = COLSCT(K) + DBLSCT(L,K) - COLGCB(K) = COLGCB(K) + DBLSCT(L,K)*DBLGCB(L,K) - ENDDO - COLGCB(K) = COLGCB(K)/(COLSCT(K)+1.D-10) - - IF ( KANORM>0 ) THEN -! ----------------------------------------------------------------- -! KANORM (default = 0) Option to renormalize aerosol column albedo -! to make column albedo less dependent on the -! number of model layers due to SGP treatment -! -! KANORM=1 aerosol column only is normalized -! -! KANORM=2 aerosol plus ground is normalized -! with Tau equivalent ground albedo -! --------------------------------- - COLPFG = COLGCB(K) - SURFBB = SRBALB(K) - TAUSBB = 0.D0 - IF ( KANORM>1 ) CALL GTSALB(XXG,XXT,SURX,SURFBB,COLPFG, & - TAUSBB,2) - DBLEXT(NL+1,K) = TAUSBB - ALLTAU = TAUSBB + COLEXT(K) - CALL SGPGXG(COSZ,ALLTAU,COLPFG,SGPG) -!c ALLGCB(K)=SGPG - DBLGCB(L1:NL,K) = SGPG - ELSE - - DO L = L1, NL - TAULAY = DBLEXT(L,K) - GCBLAY = DBLGCB(L,K) - CALL SGPGXG(COSZ,TAULAY,GCBLAY,SGPG) - DBLGCB(L,K) = SGPG - ENDDO - ENDIF - - IF ( LTOPCL/=0 ) THEN - RTAU = 1.D-10 - IF ( K==6 ) RTAU = TAURAY - COLEXT(K) = 0.D0 - COLSCT(K) = 0.D0 - COLGCB(K) = 0.D0 - DO L = L1, NL - IF ( SRCEXT(L,K)>=TCLMIN ) THEN - RTAUL = RTAU*(PLB(L)-PLB(L+1)) - SUMEXT = RTAUL + SRCEXT(L,K) + SRAEXT(L,K) & - + SRBEXT(L,K) + SRDEXT(L,K) + SRVEXT(L,K) - SUMSCT = RTAUL + SRCSCT(L,K) + SRASCT(L,K) & - + SRBSCT(L,K) + SRDSCT(L,K) + SRVSCT(L,K) - SUMGCB = SRCSCT(L,K)*SRCGCB(L,K) + SRASCT(L,K) & - *SRAGCB(L,K) + SRBSCT(L,K)*SRBGCB(L,K) & - + SRDSCT(L,K)*SRDGCB(L,K) + SRVSCT(L,K) & - *SRVGCB(L,K) - DBLEXT(L,K) = SUMEXT - DBLSCT(L,K) = SUMSCT - DBLGCB(L,K) = SUMGCB/(SUMSCT+1.D-10) - DBLPI0(L,K) = SUMSCT/(SUMEXT+1.D-10) - COLEXT(K) = COLEXT(K) + DBLEXT(L,K) - COLSCT(K) = COLSCT(K) + DBLSCT(L,K) - COLGCB(K) = COLGCB(K) + DBLSCT(L,K)*DBLGCB(L,K) - ENDIF - ENDDO - COLGCB(K) = COLGCB(K)/(COLSCT(K)+1.D-10) - -! ----------------------------------------------------------------- -! KCNORM (default = 0) Option to renormalize cloud column albedo -! to make column albedo less dependent on the -! number of model layers due to SGP treatment -! -! KCNORM=1 cloud column only is normalized -! -! KCNORM=2 cloud plus ground is normalized -! with Tau equivalent ground albedo -! --------------------------------- - IF ( KCNORM>0 ) THEN - COLPFG = COLGCB(K) - SURFBB = SRBALB(K) - TAUSBB = 0.D0 - IF ( KCNORM>1 ) CALL GTSALB(XXG,XXT,SURX,SURFBB,COLPFG, & - TAUSBB,2) - DBLEXT(NL+1,K) = TAUSBB - ALLTAU = TAUSBB + COLEXT(K) - CALL SGPGXG(COSZ,ALLTAU,COLPFG,SGPG) -!c ALLGCB(K)=SGPG - DO L = L1, NL - IF ( SRCEXT(L,K)>=TCLMIN ) DBLGCB(L,K) = SGPG - ENDDO - ELSE - DO L = L1, NL - IF ( SRCEXT(L,K)>=TCLMIN ) THEN - TAULAY = DBLEXT(L,K) - GCBLAY = DBLGCB(L,K) - CALL SGPGXG(COSZ,TAULAY,GCBLAY,SGPG) - DBLGCB(L,K) = SGPG - ENDIF - ENDDO - ENDIF - ENDIF - ENDDO - - WVCOL = SUM(ULGAS(:,1)) - ZWPATH = WVCOL*(1D0/COSZ+2D0*srbalb(6)) - -#ifdef SWFIX_20151201 - FACK12 = 0.09325D0*((ZWPATH**0.97D0)/(1.D0+5.D-4*(ZWPATH**1.31D0))& - )*0.462D-05 - FACK13 = 0.0001982D0*((WVCOL**1.08D0)*(1.D0+6.D-5*(WVCOL**0.93D0))& - )*0.277D-05 -#endif - - K = 0 - DO - K = K + 1 - - KLAM = KSLAM(K) - DKS0X = DKS0(K)*S0COSZ - -! write(*,'(a,3i5,3(e12.4,1x))')'RADIATION1: ', -! . ILON,JLAT,K,DKS0(K),S0COSZ,DKS0X - - RBNB = SRBALB(KLAM) - RBNX = SRXALB(KLAM) - RCNB = 0.D0 - RCNX = 0.D0 - SRKINC(K) = DKS0X - - DO N = L1, NL - - SRB(N) = RBNB - SRX(N) = RBNX - TLN = TLM(N) - PLN = PL(N) - ULN = ULGAS(N,1) - -! Select parameterized k-distribution gas absorption by H2O, O2, CO2 -! ------------------------------------------------------------------ - - SELECT CASE (K) - CASE (1) -!--------K=6-------H2O DS0=.01 - TERMA = (35.66+TLN*(.0416-.0004622*TLN+.001057*PLN)) & - *(1.+.04286*PLN) - TERMB = (1.+.00171*ULN)*(1.+PLN*(189.088+.1316*PLN)) - IF ( TERMB<1000. ) TERMB = 1000. - TAU1 = TERMA/TERMB - !IF(TAU1 > 0.02343) TAU1=0.02343 - IF ( TAU1>.05 ) TAU1 = .05 - TAU = TAU1*ULN - - CASE (2) -!--------K=5-------H2O DS0=.03 - TERMA = (2.792+TLN*(.0914-.0002848*TLN+.0003395*PLN)) & - *(1.+.02964*PLN) - TERMB = (1.0+.000657*ULN)*(1.+PLN*(240.70+.13847*PLN)) - IF ( TERMB<1000. ) TERMB = 1000. - TAU1 = TERMA/TERMB - !IF(TAU1 > 0.00520) TAU1=0.00520 - IF ( TAU1>.01 ) TAU1 = .01 - TAU = TAU1*ULN - - CASE (3) -!--------K=4-------H2O DS0=.04 - TERMA = (.4768+.467E-04*PLN*TLN) & - *(1.+TLN*(.00191-.719E-05*TLN)) - TERMB = (1.+.717E-04*ULN)*(1.+PLN*(130.56+.0876*PLN)) & - /(1.+.0266*PLN) - IF ( TERMB<1000. ) TERMB = 1000. - TAU1 = TERMA/TERMB - !IF(TAU1 > 0.00150) TAU1=0.0015 - IF ( TAU1>.01 ) TAU1 = .01 - TAU = TAU1*ULN - - CASE (4) -!--------K=3-------H2O DS0=.04 - TERMA = (.000247*TLN-.091+PLN*(.00035+.78E-06*TLN)) & - *(1.+.2847*PLN) - TERMB = (1.+.2066E-04*ULN)*(1.+PLN*(137.17+.16132*PLN)) - IF ( TERMA<20. ) TERMA = 20. - IF ( TERMB<1000. ) TERMB = 1000. - TAU = (TERMA/TERMB)*ULN - - CASE (5) -!--------K=2-------H2O DS0=.04 - TERMA = (PLN*(1.974/TLN+.0001117*TLN)-10.713) & - *(1.+.005788*TLN)*(1.+.001517*PLN) - TERMB = (1.+.3218E-04*ULN)*(1.+PLN*(863.44+.2048*PLN)) - IF ( TERMA<20. ) TERMA = 20. - IF ( TERMB<1000. ) TERMB = 1000. - TAU = (TERMA/TERMB)*ULN - - CASE (6) -!--------K=4-------O2 DS0=.002 - ULN = ULGAS(N,4) - TERMA = (.2236E-05-.1181E-09*TLN) & - *(1.+PLN*(.6364E-05*PLN+.001168)) - TERMB = 1. + .1521E-05*ULN - TAU = (TERMA/TERMB)*ULN - - CASE (7) -!--------K=3-------O2 DS0=.004 - ULN = ULGAS(N,4) - TERMA = (.3179E-06-.9263E-11*TLN) & - *(1.+PLN*(.8832E-05*PLN+.0005292)) - TERMB = 1. + .1968E-06*ULN - TAU = (TERMA/TERMB)*ULN - - CASE (8) -!--------K=2-------O2 DS0=.013 - ULN = ULGAS(N,4) - TERMA = (.2801E-07-.1638E-12*TLN) & - *(1.+PLN*(.1683E-04*PLN-.001721)) - TERMB = 1. + .8097E-07*ULN - TAU = (TERMA/TERMB)*ULN - - CASE (9) -!--------K=4-------CO2 DS0=.002 - ULN = ULGAS(N,2) - TERMA = (50.73-.03155*TLN-PLN*(.5543+.00091*TLN)) & - *(1.-.1004*PLN) - TERMB = (1.+.006468*ULN)*(1.+PLN*(49.51+.8285*PLN)) - TAU = (TERMA/TERMB)*ULN - IF ( PLN<175.0 ) TAU = (.00018*PLN+0.00001)*ULN - - CASE (10) -!--------K=3-------CO2 DS0=.003 - ULN = ULGAS(N,2) - TERMA = (1.+.01319*TLN) & - *(PLN*(.008001*ULN+.4589E-03)-.8396*ULN) - TERMB = ULN*(PLN+295.7+1.967*ULN) + .15126*PLN - TAU = (TERMA/TERMB)*ULN - - CASE (11) -!--------K=2-------CO2 DS0=.003 - ULN = ULGAS(N,2) - TERMA = (1.+.02257*TLN) & - *(PLN*(.002295*ULN-.5489E-04)-.7571*ULN) - TERMB = ULN*(PLN+803.9+2.477*ULN) - .09899*PLN - TAU = (TERMA/TERMB)*ULN - -! ------------------------------------------------------------------- -! fOnOff (default = 1.) scales SW long-path H2O absorption correction -! =1. fully turned on, =0. disables correction (older version) -! fOnOff is 'tunable' from 0. to 1. (introduced 7/3/2014) - - CASE (12) - !ULN=ULGAS(N,1) ! not needed because uln set to this before select case -#ifdef SWFIX_20151201 - PTROOT = (((PLN+10.0)/1000.0)**0.5D0)/SQRT(TLN/296.D0) - TAUK = PTROOT*ULN - TAU = TAUK*FACK12*FONOFF -#else - ALPH = 0.002D0 - BETA = 0.200D0 - !FACK12=1.05D-04*ZWPATH/(1.D0-1.D-05*ZWPATH) - FACK12 = .525D-04*ZWPATH/(1.D0+2.73D-04*ZWPATH) - ROOT = SQRT(((PLN+50.0)/1000.0) & - **2+1000.0*BETA*ULN/(PLN+50.0)) - TAUK = ALPH*(ROOT-(PLN+50.0)/1000.0) - TAU = TAUK*FACK12*fOnOff -#endif - - CASE (13) - !ULN=ULGAS(N,1) ! not needed because uln set to this before select case -#ifdef SWFIX_20151201 - PTROOT = (((PLN+10.0)/1000.0)**0.5D0)/SQRT(TLN/296.D0) - TAUK = PTROOT*ULN - TAU = TAUK*FACK13*FONOFF -#else - ALPH = 0.004D0 - BETA = 0.200D0 - !FACK13=1.05D-04*ZWPATH/(1.D0-1.D-05*ZWPATH) - FACK13 = .525D-04*ZWPATH/(1.D0+2.73D-04*ZWPATH) - ROOT = SQRT(((PLN+50.0)/1000.0) & - **2+1000.0*BETA*ULN/(PLN+50.0)) - TAUK = ALPH*(ROOT-(PLN+50.0)/1000.0) - TAU = TAUK*FACK13*fOnOff -#endif - - CASE (14) - TAU = XCMNO2*ULGAS(N,5) + XCMO3*ULGAS(N,3) - ENDSELECT - -! With 10 doublings to get to Tau=1.0, maximum seed tau is < 1/1024. -! ------------------------------------------------------------------ - - IF ( TAU<0.D0 ) TAU = 0.D0 - - TAU = TAU + DBLEXT(N,KLAM) - IF ( TAU>=1.D-06 ) THEN - PIZERO = DBLSCT(N,KLAM)/TAU - IF ( PIZERO>=0.001D0 ) THEN - - PFF = DBLGCB(N,KLAM) - - NDBLS = 0 - PR = 1.D0 - PFF - PT = 1.D0 + PFF - IF ( TAU>0.0019531D0 ) THEN - DBLS = 10.D0 + 1.44269D0*LOG(TAU) - NDBLS = DBLS - TAU = TAU/DBLN(NDBLS) - ENDIF - -! Set optically thin limit values of R,T,X using PI0 renormalization -! ------------------------------------------------------------------ - - XANB = EXP(-TAU-TAU) - XANX = EXP(-TAU*SECZ) - TANB = PT*XANB - XXT = (SECZ-2.D0)*TAU - TANX = PT*SECZ*(.5D0+XXT*(.25D0+XXT*(.0833333D0+XXT*( & - .0208333D0+XXT))))*XANX - RASB = PR*(1.D0-TAU*(2.D0-2.66667D0*TAU*(1.D0-TAU))) - XXT = (SECZ+2.D0)*TAU - RASX = PR*SECZ*(.5D0-XXT*(.25D0-XXT*(.0833333D0-XXT*( & - .0208333D0-XXT)))) - BNORM = (1.D0-XANB)/(RASB+TANB)*PIZERO - XNORM = (1.D0-XANX)/(RASX+TANX)*PIZERO - RASB = RASB*BNORM - RASX = RASX*XNORM - TANB = TANB*BNORM - TANX = TANX*XNORM - -! Compute and record R,T,X atmospheric layer doubling/adding results -! ------------------------------------------------------------------ - - IF ( NDBLS>=1 ) THEN - DO NN = 1, NDBLS - RARB = RASB*RASB - RARX = XANX*RASX - XATB = XANB + TANB - DENOM = 1.D0 - RARB - DB = (TANB+XANB*RARB)/DENOM - DX = (TANX+RARX*RASB)/DENOM - UB = RASB*(XANB+DB) - UX = RARX + RASB*DX - RASB = RASB + XATB*UB - RASX = RASX + XATB*UX - TANB = XANB*TANB + XATB*DB - TANX = XANX*TANX + XATB*DX - XANB = XANB*XANB - XANX = XANX*XANX - ENDDO - ENDIF - RARB = RASB*RBNB - RARX = RASB*RBNX - XATB = XANB + TANB - DENOM = 1.D0 - RARB - DB = (TANB+XANB*RARB)/DENOM - DX = (TANX+XANX*RARX)/DENOM - UB = RBNB*(XANB+DB) - UX = RBNX*XANX + RBNB*DX - RBNB = RASB + XATB*UB - RBNX = RASX + XATB*UX - XATC = XATB/(1.D0-RASB*RCNB) - RCNX = RASX + (XANX*RCNX+TANX*RCNB)*XATC - RCNB = RASB + RCNB*XATB*XATC - GOTO 190 - ENDIF - ENDIF - RASB = 0.D0 - RASX = 0.D0 - TANB = 0.D0 - TANX = 0.D0 - XANB = EXP(-TAU-TAU) - XANX = EXP(-TAU*SECZ) - DX = 0.D0 - UX = RBNX*XANX - RBNB = RBNB*XANB*XANB - RBNX = UX*XANB - RCNB = RCNB*XANB*XANB - RCNX = RCNX*XANX*XANB - 190 RNB(N) = RASB - RNX(N) = RASX - TNB(N) = TANB - TNX(N) = TANX - XNB(N) = XANB - XNX(N) = XANX - ENDDO - -! Record fluxes, spectral components at TOA, top-layer bottom edge -! ------------------------------------------------------------------ - - SRDFLB(NL+1) = SRDFLB(NL+1) + DKS0X - SRUFLB(NL+1) = SRUFLB(NL+1) + DKS0X*RBNX - SRDFLB(NL) = SRDFLB(NL) + DKS0X*(XANX+DX) - SRUFLB(NL) = SRUFLB(NL) + DKS0X*UX - SKDFLB(NL+1,K) = DKS0X - SKUFLB(NL+1,K) = DKS0X*RBNX - SKDFLB(NL,K) = DKS0X*(XANX+DX) - SKUFLB(NL,K) = DKS0X*UX - RBXTOA = RBNX - SRKALB(K) = RBNX - -! Add successively layer N (at bottom) to form upper composite layer -! ------------------------------------------------------------------ - - DO N = NL - 1, L1, -1 - XBNB = XNB(N) - XBNX = XNX(N) - RBNX = RNX(N) - IF ( RBNX>1.D-05 ) THEN - RBNB = RNB(N) - TBNB = TNB(N) - TBNX = TNX(N) - RARB = RASB*RBNB - XBTB = XBNB + TBNB - DENOM = 1.D0 - RARB - TANX = TBNX*XANX + XBTB*(TANX+XANX*RBNX*RASB)/DENOM - RASB = RBNB + XBTB*XBTB*RASB/DENOM - ELSE - RASB = RASB*XBNB*XBNB - TANX = TANX*XBNB - ENDIF - XANX = XANX*XBNX - RBNB = SRB(N) - RBNX = SRX(N) - DX = (TANX+XANX*RBNX*RASB)/(1.D0-RASB*RBNB) - UX = RBNX*XANX + RBNB*DX - SRUFLB(N) = SRUFLB(N) + DKS0X*UX - SRDFLB(N) = SRDFLB(N) + DKS0X*(XANX+DX) - SKUFLB(N,K) = DKS0X*UX - SKDFLB(N,K) = DKS0X*(XANX+DX) - ENDDO - -! Record absorbed spectral flux at ground for surface type fractions -! ------------------------------------------------------------------ - - SRKGAX(K,1:4) = DKS0X*XANX*(1.D0-PRNX(KLAM,1:4)) - SRKGAD(K,1:4) = DKS0X*DX*(1.D0-PRNB(KLAM,1:4)) - - IF ( K==NKSLAM ) THEN - - SRIVIS = DKS0X - SROVIS = DKS0X*RBXTOA - SRDVIS = SKDFLB(1,K) - SRUVIS = SKUFLB(1,K) - SRRVIS = DKS0X*RCNX - SRTVIS = DKS0X*(TANX+XANX) - SRXVIS = SRXVIS + DKS0X*XANX - -! write(*,'(a,3i5,3(e12.4,1x))')'RADIATION2: ', -! . ILON,JLAT,K,XANX,DKS0X,SRXVIS - -! ------------------------------------------------------------------ -! UV absorption by O3 and O2 within solar spectral band DKS0(15)=.05 -! ------------------------------------------------------------------ - - K = 15 - DKS0X = DKS0(K)*S0COSZ - SRKINC(K) = DKS0X -! write(*,'(a,3i5,3(e12.4,1x))')'RADIATION3: ', -! . ILON,JLAT,K,DKS0(K),S0COSZ,DKS0X - - N = NL + 1 - ATOPX = 0.D0 - ATOPD = 0.D0 - O3CMX = 0.D0 - O3CMD = 0.D0 - DO - N = N - 1 - O3CMX = O3CMX + COSMAG*ULGAS(N,3) - O3CMD = O3CMD + 1.90D0*ULGAS(N,3) - CALL AO3ABS(O3CMX,ABOTX) - CALL AO3ABS(O3CMD,ABOTD) - AO3X(N) = (ABOTX-ATOPX)/DKS0(15) - AO3D(N) = (ABOTD-ATOPD)/DKS0(15) - ATOPX = ABOTX - ATOPD = ABOTD - IF ( N<=L1 ) THEN - DO - O3CMX = O3CMX + 1.90D0*ULGAS(N,3) - O3CMD = O3CMD + 1.90D0*ULGAS(N,3) - CALL AO3ABS(O3CMX,ATOPX) - CALL AO3ABS(O3CMD,ATOPD) - AO3UXN = (ATOPX-ABOTX)/DKS0(15) - AO3UDN = (ATOPD-ABOTD)/DKS0(15) - AO3U(N) = XNX(N)*AO3UXN + (1.D0-XNX(N))*AO3UDN - ABOTX = ATOPX - ABOTD = ATOPD - N = N + 1 - IF ( N>=NL+1 ) THEN - RBNB = SRBALB(KLAM) - RBNX = SRXALB(KLAM) - RCNB = 0.D0 - RCNX = 0.D0 -! ------------------------------------- -! Get Oxygen UV absorption contribution -! ------------------------------------- -!---------------- - CALL GETO2A -!---------------- -! ------------------------------------------------------ -! Add Layers from Ground up. Retain Composite RBNB, RBNX -! R,T,X of "A" (above) layer are corrected for O3 absorption -! ---------------------------------------------------------- - - DO N = L1, NL - O2FHRL(N) = O2FHRL(N)/DKS0(15)*FULGAS(4) - O2FHRB(N) = O2FHRB(N)/DKS0(15)*FULGAS(4) - SRB(N) = RBNB - SRX(N) = RBNX - XANX = XNX(N)*(1.D0-AO3X(N)-O2FHRL(N)) - XANB = XNB(N)*(1.D0-AO3D(N)-O2FHRB(N)) - RASX = RNX(N)*(1.D0-AO3U(N)) - RASB = RNB(N)*(1.D0-AO3U(N)) - TANX = TNX(N)*(1.D0-AO3D(N)) - TANB = TNB(N)*(1.D0-AO3D(N)) -!nu ABSRTX=1.D0-XANX-TANX-RASX -!nu ABSRTB=1.D0-XANB-TANB-RASB - RARB = RASB*RBNB - RARX = RASB*RBNX - XATB = XANB + TANB - DENOM = 1.D0 - RARB - DB = (TANB+XANB*RARB)/DENOM - DX = (TANX+XANX*RARX)/DENOM - UB = RBNB*(XANB+DB) - UX = RBNX*XANX + RBNB*DX - RBNB = RASB + XATB*UB - RBNX = RASX + XATB*UX - XATC = XATB/(1.D0-RASB*RCNB) - RCNX = RASX + (XANX*RCNX+TANX*RCNB)*XATC - RCNB = RASB + RCNB*XATB*XATC - ENDDO - VRD(NL+1) = 1.D0 - VRU(NL+1) = RBNX - SRKALB(15) = RBNX - N = NL - VRD(N) = XANX + DX - VRU(N) = UX - DO - N = N - 1 - XBNX = XNX(N)*(1.D0-AO3X(N)-O2FHRL(N)) - XBNB = XNB(N)*(1.D0-AO3D(N)-O2FHRB(N)) - RBNX = RNX(N)*(1.D0-AO3U(N)) - RBNB = RNB(N)*(1.D0-AO3U(N)) - TBNX = TNX(N)*(1.D0-AO3D(N)) - TBNB = TNB(N)*(1.D0-AO3D(N)) - -! Add successively layer N (at bottom) to form upper composite layer -! ------------------------------------------------------------------ - - RARB = RASB*RBNB - XBTB = XBNB + TBNB - DENOM = 1.D0/(1.D0-RARB) - TANX = TBNX*XANX + XBTB*(TANX+XANX*RBNX*RASB)& - *DENOM - RASB = RBNB + XBTB*XBTB*RASB*DENOM - XANX = XANX*XBNX - -! Add upper bottom composite layers to get flux at layer interface -! ------------------------------------------------------------------ - - RBNB = SRB(N) - RBNX = SRX(N) - DX = (TANX+XANX*RBNX*RASB)/(1.D0-RASB*RBNB) - UX = RBNX*XANX + RBNB*DX - VRD(N) = XANX + DX - VRU(N) = UX - IF ( N<=1 ) THEN - SRKGAX(15,1:4) & - = DKS0X*XANX*(1-PRNX(6,1:4)) - SRKGAD(15,1:4) = DKS0X*DX*(1-PRNB(6,1:4)) - - DO N = L1, NL + 1 - VRD(N) = VRD(N)*DKS0X - VRU(N) = VRU(N)*DKS0X - SKDFLB(N,K) = VRD(N) - SKUFLB(N,K) = VRU(N) - ENDDO - SRIVIS = SRIVIS + VRD(NL+1) - SROVIS = SROVIS + VRU(NL+1) - PLAVIS = SROVIS/SRIVIS - SRDVIS = SRDVIS + VRD(L1) - SRUVIS = SRUVIS + VRU(L1) - ALBVIS = SRUVIS/(SRDVIS+1.D-10) - SRRVIS = SRRVIS + DKS0X*RCNX - SRTVIS = SRTVIS + DKS0X*(TANX+XANX) - SRXVIS = SRXVIS + DKS0X*XANX - SRAVIS = 1.D0 - SRRVIS - SRTVIS - -! K16 strong absorbing contributions are computed without scattering -! ------------------------------------------------------------------ - - K = 16 - DKS0X = DKS0(16)*S0COSZ - SRKINC(16) = DKS0X - SRKA16 = 0.D0 - SRKGAX(16,1:4) = 0.D0 - SRKGAD(16,1:4) = 0.D0 - DO KK = 1, 3 - IF ( KK==1 ) & - DKS0XX = DKS0X*0.002D0/0.011D0 - IF ( KK==2 ) & - DKS0XX = DKS0X*0.008D0/0.011D0 - IF ( KK==3 ) & - DKS0XX = DKS0X*0.001D0/0.011D0 - TRNC = 1.D0 - DO N = NL, L1, -1 - PLN = PL(N) - CLX = DBLEXT(N,1) - DBLSCT(N,1) - -!--------K=5-------CO2 DS0=.002 - IF ( KK==1 ) THEN - TRN1 = 0.D0 - ULN = ULGAS(N,2)*SECZ - IF ( ULN>7.D0 ) ULN = 7.D0 - TERMA = .003488*PLN* & - (1.+39.59*EXP(- & - 8.769*ULN/(1.+4.419*ULN))) & - *(1.+ & - ULN*(.001938*PLN-.00503*ULN)) - TERMB = & - (1.+.04712*PLN*(1.+.4877*ULN)) - TAUG = TERMA/TERMB*ULN - TAU1 = TAUG + CLX*SECZ - IF ( TAU1<10.0 ) & - TRN1 = EXP(-TAU1) - FAC(N) = TRN1 - ENDIF - -!--------K=7-------H2O DS0=.008 - IF ( KK==2 ) THEN - TRN2 = 0.D0 - ULN = ULGAS(N,1)*SECZ - TERMA = .001582*PLN* & - (1.+6.769*EXP(- & - 9.59*ULN/(1.+5.026*ULN))) & - *(1.+ULN* & - (.2757E-03*PLN+.001429*ULN)) - TERMB = & - (1.+.003683*PLN*(1.+1.187*ULN)& - ) - TAUG = TERMA/TERMB*ULN - TAU2 = TAUG + CLX*SECZ - IF ( TAU2<10.0 ) & - TRN2 = EXP(-TAU2) - FAC(N) = TRN2 - ENDIF - -!--------K=5-------O2 DS0=.001 - IF ( KK==3 ) THEN - TRN3 = 0.D0 - ULN = ULGAS(N,4)*SECZ - TERMA = (.1366E-03-.2203E-07*TLN)& - * & - (1.+PLN*(.1497E-06*ULN+.001261& - )) - TERMB = (1.+.3867E-03*ULN) & - /(1.+.2075E-04*ULN) - TAUG = TERMA/TERMB*ULN - TAU3 = TAUG + CLX*SECZ - IF ( TAU3<10.0 ) & - TRN3 = EXP(-TAU3) - FAC(N) = TRN3 - ENDIF - - TRNC = TRNC*FAC(N) - SRDFLB(N) = SRDFLB(N) + DKS0XX*TRNC - SKDFLB(N,K) = SKDFLB(N,K) & - + DKS0XX*TRNC - ENDDO - SRDFLB(NL+1) = SRDFLB(NL+1) + DKS0XX - SRUFLB(L1) = SRUFLB(L1) & - + DKS0XX*TRNC*SRXALB(1) - SKDFLB(NL+1,K) = SKDFLB(NL+1,K) & - + DKS0XX - SKUFLB(L1,K) = SKUFLB(L1,K) & - + DKS0XX*TRNC*SRXALB(1) - -! For completeness, any incident flux at ground is relflected upward -! ------------------------------------------------------------------ - - TRNU = TRNC - DO N = L1 + 1, NL + 1 - TRNU = TRNU*FAC(N-1) - SRUFLB(N) = SRUFLB(N) & - + DKS0XX*TRNC*SRXALB(1)*TRNU - SKUFLB(N,K) = SKUFLB(N,K) & - + DKS0XX*TRNC*SRXALB(1)*TRNU - ENDDO - SRKGAX(16,1:4) = SRKGAX(16,1:4) & - + DKS0XX*TRNC*(1-PRNX(1,1:4)) - SRKA16 = SRKA16 + TRNU*SRXALB(1) - - SRINIR = SRINIR + DKS0XX - SRONIR = SRONIR + DKS0XX*TRNU*SRXALB(1) - SRDNIR = SRDNIR + SKDFLB(L1,K) - SRUNIR = SRUNIR + SKUFLB(L1,K) - ENDDO - PLANIR = SRONIR/SRINIR - ALBNIR = SRUNIR/(SRDNIR+1.D-10) - SRKALB(16) = SRKA16/DKS0X - - SRDFLB(L1:NL+1) = SRDFLB(L1:NL+1) & - + VRD(L1:NL+1) - SRUFLB(L1:NL+1) = SRUFLB(L1:NL+1) & - + VRU(L1:NL+1) - SRNFLB(L1:NL+1) = SRDFLB(L1:NL+1) & - - SRUFLB(L1:NL+1) - SRFHRL(L1:NL) = SRNFLB(L1+1:NL+1) & - - SRNFLB(L1:NL) - SRRNIR = SRRNIR + DKS0X*RCNX - SRTNIR = SRTNIR + DKS0X*(TANX+XANX) - SRXNIR = SRXNIR + DKS0X*XANX - - S0VIS = 0.53D0*S0 - SRTVIS = SRTVIS/S0VIS - SRRVIS = SRRVIS/S0VIS - SRXVIS = SRXVIS/S0VIS - SRAVIS = 1.D0 - SRTVIS - SRRVIS - - S0NIR = 0.47D0*S0 - SRTNIR = SRTNIR/S0NIR - SRRNIR = SRRNIR/S0NIR - SRXNIR = SRXNIR/S0NIR - SRANIR = 1.D0 - SRTNIR - SRRNIR - - -! ------------------------------------------------------------------ -! FSRNFG defines the total solar flux absorbed at the ground surface -! taking into account the albedo of different surface types -! Thus: -! SRNFLB(1)=POCEAN*FSRNFG(1)+PEARTH*FSRNFG(2) -! + POICE*FSRNFG(3)+ PLICE*FSRNFG(4) -! -! NOTE: If any surface type POCEAN, PEARTH, POICE, PLICE are Zero -! the corresponding FSRNFG(I) absorbed solar flux at ground -! is computed with that surface-type albedo set equal to 0. -! --------------------------------------------------------- - - DO I = 1, 4 - FSRNFG(I) = SUM(SRKGAX(1:16,I)) & - + SUM(SRKGAD(1:16,I)) - ENDDO - - - DO K = 1, 16 - SKNFLB(L1:NL+1,K) = SKDFLB(L1:NL+1,K) & - - SKUFLB(L1:NL+1,K) - ENDDO - - DO K = 1, 16 - SKFHRL(L1:NL,K) = SKNFLB(L1+1:NL+1,K) & - - SKNFLB(L1:NL,K) - ENDDO - - DO L = L1, NL + 1 - SKDFLB(L,17) = SUM(SKDFLB(L,1:16)) - SKUFLB(L,17) = SUM(SKUFLB(L,1:16)) - SKNFLB(L,17) = SUM(SKNFLB(L,1:16)) - ENDDO - DO L = L1, NL - SKFHRL(L,17) = SUM(SKFHRL(L,1:16)) - ENDDO - GOTO 99999 - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - ENDDO - ELSE - SRINIR = SRINIR + DKS0X - SRONIR = SRONIR + DKS0X*RBXTOA - SRDNIR = SRDNIR + SKDFLB(1,K) - SRUNIR = SRUNIR + SKUFLB(1,K) - SRRNIR = SRRNIR + DKS0X*RCNX - SRTNIR = SRTNIR + DKS0X*(TANX+XANX) - SRXNIR = SRXNIR + DKS0X*XANX - ENDIF - ENDDO - -99999 END SUBROUTINE SOLARM - - - - - SUBROUTINE GETMIE(NA,AREFF,SQEX,SQSC,SQCB,TQAB,Q55) - -! INCLUDE 'rad00def.radCOMMON.f' - - INTEGER, INTENT(IN) :: NA - REAL*8, INTENT(IN) :: areff - REAL*8 SQEX(6), SQSC(6), SQCB(6), TQEX(33), TQSC(33), TQAB(33), & - Q55 - REAL*8 QXAERN(25), QSAERN(25), QGAERN(25), Q55AER(25) - - REAL*8 wts, wta, QGAERX, pi, vreff - INTEGER n0, k, n, nn - ! 1 2 3 4 - IF ( NA<5 ) THEN ! NA : Aerosol compositions SO4,SEA,ANT,OCX - N0 = 0 - IF ( NA==2 ) N0 = 22 - IF ( NA==3 ) N0 = 44 - IF ( NA==4 ) N0 = 88 - DO K = 1, 6 - DO N = 1, 22 - NN = N0 + N - WTS = FRSULF(NA) - WTA = 1.D0 - WTS - QXAERN(N) = SRUQEX(K,NN)*WTA + SRUQEX(K,N)*WTS - QSAERN(N) = SRUQSC(K,NN)*WTA + SRUQSC(K,N)*WTS - QGAERX = SRUQCB(K,NN)*SRUQSC(K,NN)*WTA + SRUQCB(K,N) & - *SRUQSC(K,N)*WTS - QGAERN(N) = QGAERX/QSAERN(N) - ENDDO - CALL SPLINE(REFU22,QXAERN,22,AREFF,SQEX(K),1.D0,1.D0,1) - CALL SPLINE(REFU22,QSAERN,22,AREFF,SQSC(K),1.D0,1.D0,1) - CALL SPLINE(REFU22,QGAERN,22,AREFF,SQCB(K),1.D0,1.D0,1) - - PI = SQSC(K)/SQEX(K) - IF ( PI>PI0MAX(NA) ) SQSC(K) = SQSC(K)*PI0MAX(NA)/PI - ENDDO - DO K = 1, 33 - DO N = 1, 22 - NN = N0 + N - WTS = FRSULF(NA) - WTA = 1.D0 - WTS - QXAERN(N) = TRUQEX(K,NN)*WTA + TRUQEX(K,N)*WTS - QSAERN(N) = TRUQSC(K,NN)*WTA + TRUQSC(K,N)*WTS - QGAERX = TRUQCB(K,NN)*TRUQSC(K,NN)*WTA + TRUQCB(K,N) & - *TRUQSC(K,N)*WTS - QGAERN(N) = QGAERX/(QSAERN(N)+1.D-20) - ENDDO - CALL SPLINE(REFU22,QXAERN,22,AREFF,TQEX(K),1.D0,1.D0,1) - CALL SPLINE(REFU22,QSAERN,22,AREFF,TQSC(K),1.D0,1.D0,1) - TQAB(K) = TQEX(K) - TQSC(K) - ENDDO - DO N = 1, 22 - NN = N0 + N - WTS = FRSULF(NA) - WTA = 1.D0 - WTS - Q55AER(N) = Q55U22(NN)*WTA + Q55U22(N)*WTS - ENDDO - CALL SPLINE(REFU22,Q55U22,22,AREFF,Q55,1.D0,1.D0,1) - ENDIF - - ! 5 6 - IF ( NA==5 .OR. NA==6 ) THEN - ! NA : Aerosol compositions BIC,BCB -!c AREFF=REFDRY(NA) - DO K = 1, 6 - QXAERN(:) = SRSQEX(K,:) - ! 1:25 - QSAERN(:) = SRSQSC(K,:) - ! 1:25 - QGAERN(:) = SRSQCB(K,:) - ! 1:25 - CALL SPLINE(REFS25,QXAERN,25,AREFF,SQEX(K),1.D0,1.D0,1) - CALL SPLINE(REFS25,QSAERN,25,AREFF,SQSC(K),1.D0,1.D0,1) - CALL SPLINE(REFS25,QGAERN,25,AREFF,SQCB(K),1.D0,1.D0,1) - ENDDO - DO K = 1, 33 - QXAERN(:) = TRSQEX(K,:) - ! 1:25 - QSAERN(:) = TRSQSC(K,:) - ! 1:25 - QGAERN(:) = TRSQCB(K,:) - ! 1:25 - CALL SPLINE(REFS25,QXAERN,25,AREFF,TQEX(K),1.D0,1.D0,1) - CALL SPLINE(REFS25,QSAERN,25,AREFF,TQSC(K),1.D0,1.D0,1) - TQAB(K) = TQEX(K) - TQSC(K) - ENDDO - CALL SPLINE(REFS25,Q55S25,25,AREFF,Q55,1.D0,1.D0,1) - ENDIF - - ! 7 - IF ( NA==7 ) THEN ! NA : Aerosol composition DST -!c AREFF=REFDRY(NA) - DO K = 1, 6 - QXAERN(:) = SRDQEX(K,:) - ! 1:25 - QSAERN(:) = SRDQSC(K,:) - ! 1:25 - QGAERN(:) = SRDQCB(K,:) - ! 1:25 - CALL SPLINE(REFD25,QXAERN,25,AREFF,SQEX(K),1.D0,1.D0,1) - CALL SPLINE(REFD25,QSAERN,25,AREFF,SQSC(K),1.D0,1.D0,1) - CALL SPLINE(REFD25,QGAERN,25,AREFF,SQCB(K),1.D0,1.D0,1) - ENDDO - DO K = 1, 33 - QXAERN(:) = TRDQEX(K,:) - ! 1:25 - QSAERN(:) = TRDQSC(K,:) - ! 1:25 - QGAERN(:) = TRDQCB(K,:) - ! 1:25 - CALL SPLINE(REFD25,QXAERN,25,AREFF,TQEX(K),1.D0,1.D0,1) - CALL SPLINE(REFD25,QSAERN,25,AREFF,TQSC(K),1.D0,1.D0,1) - TQAB(K) = TQEX(K) - TQSC(K) - ENDDO - CALL SPLINE(REFD25,Q55D25,25,AREFF,Q55,1.D0,1.D0,1) - ENDIF - - ! 8 - IF ( NA==8 ) THEN ! NA : Aerosol composition(H2SO4) VOL - VREFF = AREFF - IF ( VREFF<0.1D0 ) VREFF = 0.1D0 - IF ( VREFF>2.0D0 ) VREFF = 2.0D0 - CALL GETQVA(VREFF) - SQEX(:) = QVH2S(:) ! 1:6 - SQSC(:) = SVH2S(:) ! 1:6 - SQCB(:) = GVH2S(:) ! 1:6 - TQAB(:) = AVH2S(:) ! 1:33 - Q55 = Q55H2S - ENDIF - END SUBROUTINE GETMIE - - SUBROUTINE AO3ABS(OCM,O3ABS) - IMPLICIT NONE -! --------------------------------------------------------- -! UV absorption by Ozone is expressed as a fraction of the -! total solar flux S0. Hence O3ABS (fraction of total solar -! flux absored by OCM cm ofozone) must be normalized within -! SOLARM by dividing O3ABS by the corresponding fraction of -! the solar flux within the spectral interval DKS0(15)=0.05 -! --------------------------------------------------------- - REAL*8, INTENT(IN) :: OCM - REAL*8, INTENT(OUT) :: O3ABS - REAL*8 XX, DX - INTEGER IP, IX - - O3ABS = AO3(460) - IP = 0 - XX = OCM*1.D+04 - IX = XX - IF ( IX>99 ) THEN - DO - IP = IP + 90 - XX = XX*0.1D0 - IX = XX - IF ( IX<=99 ) EXIT - ENDDO - ELSEIF ( IX<1 ) THEN - O3ABS = XX*AO3(1) - GOTO 140 - ENDIF - DX = XX - IX - IX = IX + IP - IF ( IX<=459 ) O3ABS = AO3(IX) + DX*(AO3(IX+1)-AO3(IX)) - - 140 END SUBROUTINE AO3ABS - - SUBROUTINE WRITER(KWRU,INDEX) -! -! USE SURF_ALBEDO, only : AVSCAT, ANSCAT, AVFOAM, ANFOAM, -! * WETTRA, WETSRA, ZOCSRA, ZSNSRA, ZICSRA, ZDSSRA, ZVGSRA, -! * EOCTRA, ESNTRA, EICTRA, EDSTRA, EVGTRA, AGEXPF, ALBDIF - USE SURF_ALBEDO, ONLY:GET_ALBEDO_DATA - USE DOMAIN_DECOMP_ATM, ONLY:AM_I_ROOT - USE DUSTPARAM_MOD, ONLY:REDUST - IMPLICIT NONE -! -! ------------------------------------------------------------------ -! WRITER Radiative Input/Output Cloud/Aerosol Data/Conrol Parameters -! -! INDEX -! 0 control parameter defaults in RADPAR -! 1 RADPAR Radiative control/scaling params; GHG defaults -! 2 RADPAR Atmospheric composition P,H,T,Cld,Aer profiles -! 3 RADPAR Computed LW SW fluxes cooling and heating rates -! 4 Aerosol and Cloud: Mie scattering radiative parameters -! A SW aerosol Mie scattering Qx,Qs,g in use parameters -! B SW cloud Mie scattering Qx,Qs,g in use parameters -! C SW cld+aer Mie scattering Qx,Qs,g in use parameters -! D SW LW aerosol 11-compositon Mie Qx,Qs,g parameters -! E SW LW aerosol 6-compositon Mie Qx,Qs,g parameters -! F SW LW aerosol 8-size D dust Mie Qx,Qs,g parameters -! G SW LW cloud 15-size/phase Mie Qx,Qs,g parameters -! 5 LW cld,aer,gas total optical k-distribution extinction -! 6 LW gas absorb: total optical k-distribution extinction -! 7 A LW cloud TRCALK optical k-distribution extinction -! B LW aerosol TRAALK optical k-distribution extinction -! 8 SW Spectral/k-dist flux, albedo, absorption components -! A Spectral components of downward upward solar flux -! B Spectral components of net solar flux, heating rate -! 9 LW flux contribution from each k-distribution interval -! 1 Downward LW flux from each k-distribution interval -! 2 Upward LW flux from each k-distribution interval -! 3 Net (Up) LW flux from each k-distribution interval -! 4 Flux cooling rate from each k-distribution interval -! 5 Fraction coolrate from each k-distribution interval -! NOTE: -! KWTRAB sets LW Mie parameters in 4-D,E,F,G -! KWTRAB=0 (default) sets LW output to be Mie Qab -! KWTRAB=1 sets LW output to be Mie Qex -! KWTRAB=2 sets LW output to be Mie Qsc -! KWTRAB=3 sets LW output to be Mie Qcb -! KWTRAB=4 sets LW output to be Mie Pi0 -! -! INDEX 0-9 : show item 'INDEX' only -! INDEX 11-19: show items 1->last digit of 'INDEX' -! INDEX 21-29: show items 0->last digit of 'INDEX' -! KWRU directs the output to selected (KWRU) file number -! ------------------------------------------------------------------ -! - INTEGER, INTENT(IN) :: INDEX - REAL*8 AVSCAT, ANSCAT, AVFOAM, ANFOAM, WETTRA, WETSRA, ZOCSRA, & - ZSNSRA, ZICSRA, ZDSSRA, ZVGSRA, EOCTRA, ESNTRA, EICTRA, & - EDSTRA, EVGTRA, AGEXPF(3,2), ALBDIF(3,2) -!!nu TROPOSPHERIC AEROSOL effective radius -!!nu BCI OCI SUI SEA SUN ANT OCN OCB BCB SSB - REAL*8, DIMENSION(10) :: REAERO = (/0.1,0.3,0.3,2.0,0.3,1.0,0.3,& - 0.3,0.2,0.5/) - ! no longer needed except in writer - CHARACTER*8, PARAMETER :: FTYPE(5) & - = (/'DOWNWARD',' UPWARD','UPWD NET',& - &'COOLRATE','FRACTION'/) - CHARACTER*6, PARAMETER :: GHG(12) & - = (/' H2O',' CO2',' O3', & - &' O2',' NO2',' N2O',' CH4', & - &'CCL3P1','CCL2P2',' N2',' CFC-Y', & - &' CFC-Z'/) - CHARACTER*3 TRABCD(5), TRAXSG(5), snotyp - DATA TRABCD/'TRA', 'TRB', 'TRC', 'TRD', 'TRE'/ - DATA TRAXSG/'QAB', 'QEX', 'QSC', 'QCB', 'PI0'/ - - REAL*8 TKEFF(3), TRPI0K(25) - REAL*8 WFLB(LX,33), WFSL(33), UXGAS(LX,9) - REAL*8 BGFLUX(33), BGFRAC(33), TAUSUM(33) - REAL*8 SUM0(20), SUM1(LX+1), SUM2(LX+1), SUM3(LX+1) - REAL*8, DIMENSION(LX,6) :: WSREXT, WSRSCT, WSRGCB, WSRPI0 - REAL*8 FSR1(17), FSR2(17) - INTEGER :: ISR1(16), KWRU - INTEGER, PARAMETER :: KSLAMW(16) & - = (/1,1,2,2,5,5,5,5,1,1,1,3,4,6,6,1/), & - IORDER(16) & - = (/12,11,10,9,6,5,4,3,15,14,13,8,7,2,1, & - 16/) - - CHARACTER*1, PARAMETER :: AUXGAS(4) = (/'0','L','X','X'/) - REAL*8, PARAMETER :: P0 = 1013.25, SIGMA = 5.6697D-08 - REAL*8 ACOLX, BCOLX, DCOLX, VCOLX, TCOLX, FACTOR, PPMCO2, PPMO2, & - PPMN2O, PPMCH4, PPMF11, PPMF12, PPMY11, PPMZ12, EPS, TAER, & - HLM, TLAPS, TAU55, TGMEAN, PSUM, SRALB, STNFLB, CRHRF, & - STFHR, TRDCR, SRDHR, STDHR, PFW, DPF, FRACSL, SIGT4, WTG, & - SUMK, SUMT, SUMK1, SUMK2, ASUM1, BSUM1, CSUM1, DSUM1, & - ESUM1, FSUM1, ASUM2, BSUM2, CSUM2, DSUM2, ESUM2, FSUM2, & - ASUM3, BSUM3, CSUM3, DSUM3, ESUM3, FSUM3, SUML, SUMA, SUMB,& - SUMC, SUMD, SUME, SUMF - INTEGER I, J, K, L, KW, INDJ, INDI, INDX, KPAGE, NPAGE, LUXGAS, & - LGS, IPI0, IRHL, N, II, IPF, ITG, LK, KK, NW, LINFIL - - CALL GET_ALBEDO_DATA(AVSCAT,ANSCAT,AVFOAM,ANFOAM,WETTRA,WETSRA, & - ZOCSRA,ZSNSRA,ZICSRA,ZDSSRA,ZVGSRA,EOCTRA, & - ESNTRA,EICTRA,EDSTRA,EVGTRA,AGEXPF,ALBDIF) - - KW = KWRU - INDJ = MOD(INDEX,10) - IF ( INDJ<1 .AND. INDEX>0 ) INDJ = 10 - INDI = 1 - IF ( INDEX>20 .OR. INDEX==0 ) INDI = 0 - IF ( INDEX<11 ) INDI = INDJ - - IF ( INDJ>0 ) THEN - DO K = 1, 6 - DO L = L1, NL - WSREXT(L,K) = SRAEXT(L,K) + SRBEXT(L,K) + SRDEXT(L,K) & - + SRVEXT(L,K) - WSRSCT(L,K) = SRASCT(L,K) + SRBSCT(L,K) + SRDSCT(L,K) & - + SRVSCT(L,K) - WSRGCB(L,K) = SRASCT(L,K)*SRAGCB(L,K) + SRBSCT(L,K) & - *SRBGCB(L,K) + SRDSCT(L,K)*SRDGCB(L,K) & - + SRVSCT(L,K)*SRVGCB(L,K) - WSRPI0(L,K) = WSRSCT(L,K)/(WSREXT(L,K)+1.E-10) - WSRGCB(L,K) = WSRGCB(L,K)/(WSRSCT(L,K)+1.D-10) - ENDDO - ENDDO -! - ACOLX = SUM(SRAEXT(L1:NL,6)) - BCOLX = SUM(SRBEXT(L1:NL,6)) - DCOLX = SUM(SRDEXT(L1:NL,6)) - VCOLX = SUM(SRVEXT(L1:NL,6)) - TCOLX = ACOLX + BCOLX + DCOLX + VCOLX - ENDIF - - DO INDX = INDI, INDJ - - KPAGE = 1 - IF ( INDX/=0 ) THEN - - IF ( INDX==1 ) THEN -! -!------------- -!------------- -! - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6101) -! - 6101 FORMAT (' (1)FUL: 1',7X,'2',8X,'3',7X,'6',7X,'7',8X,'8',& - 8X,'9',8X,'11',7X,'12',4X, & - &'RADPAR 1/F: (Control/Default', & - &'/Scaling Parameters)') - WRITE (KW,6102) - 6102 FORMAT (4X,'GAS: ','H2O',5X,'CO2',7X,'O3',5X,'N2O',5X, & - &'CH4',5X,'CFC-11',3X,'CFC-12',3X,'CFY-11',3X, & - &'CFZ-12',2X, & - &'Aerosol Global Ocean Land Desert Haze'& - ) - FACTOR = 1D0/((PLB(L1)-PLB(L1+1))*PPMV_TO_CM_AT_STP) - PPMCO2 = ULGAS(L1,2)*FACTOR - PPMO2 = ULGAS(L1,4)*FACTOR - PPMN2O = ULGAS(L1,6)*FACTOR - PPMCH4 = ULGAS(L1,7)*FACTOR - PPMF11 = ULGAS(L1,8)*FACTOR - PPMF12 = ULGAS(L1,9)*FACTOR - PPMY11 = ULGAS(L1,11)*FACTOR - PPMZ12 = ULGAS(L1,12)*FACTOR - WRITE (KW,6103) (FULGAS(I),I=1,3), (FULGAS(I),I=6,9), & - FULGAS(11), FULGAS(12), (FGOLDH(I),I=1,5) - 6103 FORMAT (1X,'FULGAS=',F5.3,F10.5,F7.3,F9.5,F8.5,4F9.5,2X, & - &'FGOLDH=',F7.5,2F9.6,2F8.5) -! IF(KGASSR > 0) -! +WRITE(KW,6104) (FULGAS(I+9),I=1,2),(FULGAS(I+9),I=4,9) -! + ,FULGAS(11),FULGAS(12), (FGOLDH(I+9),I=1,5) - WRITE (KW,6105) PPMCO2, PPMN2O, PPMCH4, PPMF11, PPMF12, & - PPMY11, PPMZ12, (FSTOPX(I),I=1,4), & - PPMV80(2), (PPMV80(I),I=6,9), & - (PPMV80(I),I=11,12), KTREND, JYEAR, JDAY,& - LASTVC -!6104 FORMAT('+',T84,'T' -! + /1X,'FULGAS=',1P,1E7.1,1P,2E8.1,1P,2E8.1,1P,4E9.1 -! + ,' S','FGOLDH=',1P,1E7.1,1P,2E9.2,1P,2E8.1) - 6105 FORMAT (1X,'PPM(1)=(now)',2X,F8.3,8X,F8.5,F8.5,4(1X,F8.7)& - ,2X,'TRACER=',F7.5,2F9.6,F8.5/' PPMV80=(ref)=', & - 0P,F9.3,8X,2F8.5,4(1X,F8.7),2X,'KTREND=',I1,2X, & - &'JYEAR=',I4,' JDAY=',I3,5X,'LASTVC=',I7) - WRITE (KW,6106) TAUWC0, FCLDTR, EOCTRA, ZOCSRA, KZSNOW, & - KCLDEM, NTRACE, FSAAER, FTTAER, KCLDEP, & - MADO3M, L1 - 6106 FORMAT (1X,'TAUWC0=',1P,E6.0,' FCLDTR=',0P,F4.2, & - &' EOCTRA=',F3.1,1X,'ZOCSRA=',F3.1,' KZSNOW=',I4, & - &' KCLDEM=',I3,1X,'NTRACE=',I3,2X,'FSTAER=',F3.1, & - &' FTTAER=',F3.1,1X,'KCLDEP=',I1,1X,'MADO3M=',I2, & - &' L1=',I3) - WRITE (KW,6107) TAUIC0, FCLDSR, ESNTRA, ZSNSRA, WETTRA, & - KSIALB, ITR(1), ITR(5), FSBAER, FTBAER, & - KEEPAL, NL - 6107 FORMAT (1X,'TAUIC0=',1P,E6.0,' FCLDSR=',0P,F4.2, & - &' ESNTRA=',F3.1,1X,'ZSNSRA=',F3.1,1X,'WETTRA=', & - F4.2,' KSIALB=',I3,1X,'ITR(1)=',2I2,1X,'FSBAER=',& - F3.1,' FTBAER=',F3.1,1X,'KEEPAL=',I1,1X, & - ' ',' ',' NL=',I3) - WRITE (KW,6108) FRAYLE, EICTRA, ZICSRA, WETSRA, KCNORM, & - ITR(2), ITR(6), FSAAER, FTAAER, KEEP10, & - MLAT46 - 6108 FORMAT (1X,' ',6X,' FRAYLE=',0P,F4.1,' EICTRA=', & - F3.1,1X,'ZICSRA=',F3.1,1X,'WETSRA=',F4.2, & - &' KCNORM=',I3,1X,'ITR(2)=',2I2,1X,'FSAAER=',F3.1,& - &' FTAAER=',F3.1,1X,'KEEP10=',I1,1X,' ',' ',& - &' MLAT46=',I2) - WRITE (KW,6109) TLGRAD, ECLTRA, EDSTRA, ZDSSRA, KANORM, & - KPGRAD, ITR(3), ITR(7), FSDAER, FTDAER, & - KWVCON, ICE012, MLON72 - 6109 FORMAT (1X,'TLGRAD=',F6.2,' ECLTRA=',0P,F4.2,' EDSTRA=', & - F3.1,1X,'ZDSSRA=',F3.1,1X,'KANORM=',I4, & - ' KPGRAD=',I3,1X,'ITR(3)=',2I2,1X,'FSDAER=',F3.1,& - &' FTDAER=',F3.1,1X,'KWVCON=',I1,1X,'ICE012=',I1, & - &' MLON72=',I2) - WRITE (KW,6110) PTLISO, EVGTRA, ZVGSRA, KEEPRH, KLATZ0, & - ITR(4), ITR(8), FSVAER, FTVAER, KSOLAR, & - NORMS0 - 6110 FORMAT (1X,'PTLISO=',F6.1,1X,' ',' EVGTRA=', & - F3.1,1X,'ZVGSRA=',F3.1,1X,'KEEPRH=',I4, & - ' KLATZ0=',I3,1X,'ITR(4)=',2I2,1X,'FSVAER=',F3.1,& - &' FTVAER=',F3.1,1X,'KSOLAR=',I1,1X,'NORMS0=',I1, & - &' ') - CYCLE - ELSEIF ( INDX==2 ) THEN -! -!------------- -!------------- -! - NPAGE = 0 - LUXGAS = 0 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6201) AUXGAS(LUXGAS+1), S00WM2, S0, COSZ - 6201 FORMAT (' (2) RADPAR G/L: (Input Data)',2X, & - &'Absorber Amount per Layer:',' U',1A1, & - &'GAS(L,K) in cm**3(STP)/cm**2',2X,'S00WM2=',F9.4,& - 1X,'S0=',F9.4,2X,'COSZ=',F6.4/ & - &' LN PL HLM TLM TLAP SHL .RH ', & - &'H2O CO2 O3 N2O CH4 CFC-11', & - &' CFC-12 NO2 WC.SIZ.IC WC.TAU.IC CLEP A TAU PI0'& - ) - DO K = 1, 9 - DO L = L1, NL - UXGAS(L,K) = ULGAS(L,K) - ENDDO - ENDDO - IF ( LUXGAS>=2 ) THEN - LGS = (LUXGAS-2)*9 - DO L = L1, NL - UXGAS(L,1) = U0GAS(L,1)*FULGAS(1+LGS) - UXGAS(L,3) = U0GAS(L,3)*FULGAS(3+LGS) - UXGAS(L,5) = U0GAS(L,5)*FULGAS(5+LGS) - ENDDO -! - DO L = L1, NL - UXGAS(L,2) = U0GAS(L,2)*FULGAS(2+LGS) - UXGAS(L,4) = U0GAS(L,4)*FULGAS(4+LGS) - UXGAS(L,6) = U0GAS(L,6)*FULGAS(6+LGS) - UXGAS(L,7) = U0GAS(L,7)*FULGAS(7+LGS) - UXGAS(L,8) = U0GAS(L,8)*FULGAS(8+LGS) - UXGAS(L,9) = U0GAS(L,9)*FULGAS(9+LGS) - ENDDO - ENDIF - DO L = NL, L1, -1 - EPS = CLDEPS(L) - TAER = WSREXT(L,6) - IPI0 = WSRPI0(L,6)*1000.D0 + 1.D-05 - HLM = 0.5D0*(HLB0(L+1)+HLB0(L)) - TLAPS = (TLT(L)-TLB(L))/MAX(1D-3,HLB0(L+1)-HLB0(L)) - IRHL = RHL(L)*100.0 - IF ( PL(L)<1.D0 ) THEN - WRITE (KW,6212) L, PL(L), HLM, TLM(L), TLAPS, & - SHL(L), IRHL, (UXGAS(L,K),K=1,3), & - (UXGAS(L,K),K=6,9), UXGAS(L,5), & - SIZEWC(L), SIZEIC(L), & - FTAUC*TAUWC(L), FTAUC*TAUIC(L), & - EPS, TAER, IPI0 - 6212 FORMAT (1X,I2,F7.4,F5.1,F7.2,F5.1,1X,F7.6,I3,F8.5, & - F6.2,1X,F6.5,1X,F5.4,F7.4,1P,3E8.1,0P, & - 2F5.1,F6.2,F5.2,1X,F4.3,F6.3,I5) - ELSEIF ( UXGAS(L,1)>=1.D0 ) THEN - WRITE (KW,6202) L, PL(L), HLM, TLM(L), TLAPS, & - SHL(L), IRHL, (UXGAS(L,K),K=1,3), & - (UXGAS(L,K),K=6,9), UXGAS(L,5), & - SIZEWC(L), SIZEIC(L), & - FTAUC*TAUWC(L), FTAUC*TAUIC(L), & - EPS, TAER, IPI0 - 6202 FORMAT (1X,I2,F7.2,F5.1,F7.2,F5.1,1X,F7.6,I3,F8.2, & - F6.2,1X,F6.5,1X,F5.4,F7.4,1P,3E8.1,0P, & - 2F5.1,F6.2,F5.2,1X,F4.3,F6.3,I5) - ELSE - WRITE (KW,6211) L, PL(L), HLM, TLM(L), TLAPS, & - SHL(L), IRHL, (UXGAS(L,K),K=1,3), & - (UXGAS(L,K),K=6,9), UXGAS(L,5), & - SIZEWC(L), SIZEIC(L), & - FTAUC*TAUWC(L), FTAUC*TAUIC(L), & - EPS, TAER, IPI0 - 6211 FORMAT (1X,I2,F7.2,F5.1,F7.2,F5.1,1X,F7.6,I3,F8.5, & - F6.2,1X,F6.5,1X,F5.4,F7.4,1P,3E8.1,0P, & - 2F5.1,F6.2,F5.2,1X,F4.3,F6.3,I5) - ENDIF - ENDDO - DO I = 1, 16 - SUM0(I) = 0. - ENDDO - DO L = L1, NL - DO I = 1, 9 - SUM0(I) = SUM0(I) + ULGAS(L,I) - ENDDO - DO I = 1, 4 - SUM0(12+I) = SUM0(12+I) + TRACER(L,I) & - *1D3*.75D0/DENAER(ITR(I)) & - *Q55DRY(ITR(I))/TRRDRY(I) - ENDDO - SUM0(10) = SUM0(10) + FTAUC*TAUWC(L) - SUM0(11) = SUM0(11) + FTAUC*TAUIC(L) - ENDDO - TAU55 = 0.0 - DO L = L1, NL - TAU55 = TAU55 + WSREXT(L,6) - ENDDO - SUM0(12) = TAU55 - TGMEAN = POCEAN*TGO**4 + PEARTH*TGE**4 + PLICE*TGLI**4 + & - POICE*TGOI**4 - TGMEAN = SQRT(TGMEAN) - TGMEAN = SQRT(TGMEAN) - WRITE (KW,6203) (SUM0(I),I=1,3), (SUM0(I),I=6,9), SUM0(5)& - , SUM0(10), SUM0(11), SUM0(12) - 6203 FORMAT (24X,' Column Amount',F7.1,F7.2,1X,F6.5,1X,F5.4, & - F7.4,1P,3E8.1,0P,10X,F6.2,F5.2,5X,F6.3) - WRITE (KW,6204) POCEAN, TGO, PLAKE, zlake, SUM0(13), & - JYEAR, BXA(4:5), LASTVC - 6204 FORMAT (1X,'PWATER=',F6.4,' TGO=',F6.2,1X,' PLAKE=', & - F6.3,1X,' ZLAKE=',F6.3,' TRACER 1=',F5.3, & - &' JYEAR=',I4,3X,'BSNVIS=',F6.4,' BSNNIR=',F6.4, & - 7X,'LASTVC=',I7) - WRITE (KW,6205) PEARTH, TGE, SNOWD, ZSNWOI, SUM0(14), & - JDAY, BXA(6:7) - 6205 FORMAT (' PEARTH=',F6.4,' TGE=',F6.2,' SNOWD=',2F6.3,& - &' ZSNOW=',F6.3,' Sums: 2=',F5.3,' JDAY=',I4, & - 2X,' XSNVIS=',F6.4,' XSNNIR=',F6.4,8X, & - &'NIRALB VISALB') - WRITE (KW,6206) POICE, TGOI, SNOWOI, ZOICE, SUM0(15), & - JLAT, (SRBALB(I),I=1,6) - 6206 FORMAT (' POICE=',F6.4,' TGOI=',F6.2,' SNOWOI=',F6.3, & - &' ZOICE=',F6.3,' 3=',F5.3,' JLAT=',I4, & - 2X,' SRBALB=',F6.4,4F7.4,F7.4) - WRITE (KW,6207) PLICE, TGLI, SNOWLI, zmp, SUM0(16), ILON,& - (SRXALB(I),I=1,6) - 6207 FORMAT (' PLICE=',F6.4,' TGLI=',F6.2,' SNOWLI=',F6.3, & - &' ZMLTP=',F6.3,' 4=',F5.3,' ILON=',I4, & - 2X,' SRXALB=',F6.4,4F7.4,F7.4) - PSUM = POCEAN + PEARTH + POICE + PLICE - snotyp = 'DRY' - IF ( flags ) snotyp = 'WET' - WRITE (KW,6208) TGMEAN, snotyp, fmp, PSUM, TSL, WMAG, & - LS1_loc, (PVT(I),I=1,11) - 6208 FORMAT (8X,6('-'),' TGMEAN=',F6.2,' SNOW : ',a3, & - &' FMLTP=',F6.3, & - &' BSAND TUNDRA GRASSL SHRUBS TREES DECIDF', & - &' EVERGF',' RAINF',' CROPS',' BDIRT', & - ' ALGAE'/' PSUM=',F6.4,' TSL=',F6.2, & - &' WINDSP=',F6.3,' LS1L=',I2,T54,'PVT=',F6.4, & - 10F7.4) - WRITE (kw,6213) snow_frac(1), snow_frac(2), agesn(1), & - agesn(2), agesn(3), wearth, fulgas(4), & - fulgas(5), fulgas(10) - 6213 FORMAT (1X,'FSNWds=',F6.4,' FSNWvg=',F6.4,' AGESN=[EA:',& - F6.3,' OI:',F6.3,' LI:',F6.3,'] WEARTH=',F6.4,1X,& - &' FULGAS[ 4=O2:',F3.1,' 5=NO2:',F3.1,' 10=N2C:', & - F3.1,']') - WRITE (KW,6209) (PRNB(1:2,I),PRNX(1:2,I),I=1,4), BXA(1:3) - 6209 FORMAT ( & - &' BOCVIS BOCNIR XOCVIS XOCNIR BEAVIS BEANIR XEAVIS XEANIR'& - , & - &' BOIVIS BOINIR XOIVIS XOINIR BLIVIS BLINIR XLIVIS XLINIR'& - ,' EXPSNE EXPSNO EXPSNL'/1X,F6.4,18F7.4) - WRITE (KW,6210) - 6210 FORMAT (' ') -! - CYCLE - ELSEIF ( INDX==3 ) THEN -! -!------------- -!------------- -! - NPAGE = 0 - IF ( INDEX<11 ) NPAGE = KPAGE - IF ( NL>13 ) NPAGE = 1 - L = NL + 1 - SRALB = SRUFLB(L)/(SRDFLB(L)+1.E-10) - STNFLB = SRNFLB(L) - TRNFLB(L) - WRITE (KW,6301) NORMS0 -! -! - 6301 FORMAT (/' (3) RADPAR M/S: (Output Data)',T37, & - &'Thermal Fluxes (W/M**2)',4X, & - &'Solar Fluxes (W/M**2)',1X,'NORMS0=',I1, & - &' Energy Input Heat/Cool Deg/Day Alb', & - &'do'/' LN PLB HLB TLB TLT ', & - &' TRDFLB TRUFLB TRNFLB TRFCRL SRDFLB SRUFLB SRNFLB'& - ,' SRFHRL STNFLB STFHR SR-TR TR=CR SR=HR SRALB') - WRITE (KW,6302) L, PLB(L), HLB0(L), TLT(L-1), TRDFLB(L), & - TRUFLB(L), TRNFLB(L), SRDFLB(L), & - SRUFLB(L), SRNFLB(L), STNFLB, SRALB - ! TLB(LN+1) unused/set - 6302 FORMAT (1X,I2,F9.3,F6.2,1X,F6.2,8X,3F7.2,8X,3F8.2,7X, & - F8.2,26X,F6.4) - DO L = NL, L1, -1 - CRHRF = 8.4167/(PLB(L)-PLB(L+1)) - STNFLB = SRNFLB(L) - TRNFLB(L) - STFHR = SRFHRL(L) - TRFCRL(L) - TRDCR = TRFCRL(L)*CRHRF - SRDHR = SRFHRL(L)*CRHRF - STDHR = STFHR*CRHRF - SRALB = SRUFLB(L)/(SRDFLB(L)+1.E-10) -!eq SRXVIS=SRXATM(1) -!eq SRXNIR=SRXATM(2) - IF ( PLB(L)<1.D0 ) THEN - WRITE (KW,6313) L, PLB(L), HLB0(L), TLB(L), TLT(L),& - TRDFLB(L), TRUFLB(L), TRNFLB(L), & - TRFCRL(L), SRDFLB(L), SRUFLB(L), & - SRNFLB(L), SRFHRL(L), STNFLB, & - STFHR, STDHR, TRDCR, SRDHR, SRALB - 6313 FORMAT (1X,I2,F9.5,F6.2,2F7.2,1X,F7.4,2F7.2,F7.4, & - 1X,3F8.2,F7.4,1X,F7.2,F7.4,1X,3F6.2,1X, & - F5.4) - ELSE - WRITE (KW,6303) L, PLB(L), HLB0(L), TLB(L), TLT(L),& - TRDFLB(L), TRUFLB(L), TRNFLB(L), & - TRFCRL(L), SRDFLB(L), SRUFLB(L), & - SRNFLB(L), SRFHRL(L), STNFLB, & - STFHR, STDHR, TRDCR, SRDHR, SRALB - 6303 FORMAT (1X,I2,F9.3,F6.2,2F7.2,1X,3F7.2,F7.2,1X, & - 3F8.2,F7.2,1X,F7.2,1X,F6.2,1X,3F6.2,1X, & - F5.4) - ENDIF - ENDDO -! - DO II = 1, 3 - PFW = TRDFLB(L1) - IF ( II==2 ) PFW = TRUFLB(L1) - IF ( II==3 ) PFW = TRUFLB(NL+1) - IPF = PFW - DPF = PFW - IPF - IF ( IPF<1 ) IPF = 1 - IF ( IPF>899 ) IPF = 899 - TKEFF(II) = TKPFT(IPF) + DPF*(TKPFT(IPF+1)-TKPFT(IPF)) - ENDDO -! - WRITE (KW,6304) WINDZF(1), WINDZT(1), TOTLZF(1), & - TOTLZT(1), (FSRNFG(I),I=1,4), LTOPCL, & - JLAT, JYEAR - 6304 FORMAT (1X,'XMU WINDZF WINDZT TOTLZF TOTLZT'/1X,'1.0',& - 1X,F7.3,F7.2,2X,F7.3,F7.2,2X,'FR.SRNLB1', & - &' OCEAN=',F7.2,' EARTH=',F7.2,' OICE=',F7.2, & - &' LICE=',F7.2,1X,' LTOPCL=',I2,' JLAT=',I2, & - &' JYEAR=',I4) - WRITE (KW,6305) WINDZF(2), WINDZT(2), TOTLZF(2), & - TOTLZT(2), (FTRUFG(I),I=1,4), LBOTCL, & - ILON, JDAY - 6305 FORMAT (1X,'0.5',1X,F7.3,F7.2,2X,F7.3,F7.2,2X, & - 'FR.TRULB1',' OCEAN=',F7.4,' EARTH=',F7.4, & - &' OICE=',F7.4,' LICE=',F7.4,1X,' LBOTCL=',I2, & - &' ILON=',I2,' JDAY=',I4) - IF ( KORDER==0 ) WRITE (KW,6306) WINDZF(3), WINDZT(3), & - TOTLZF(3), TOTLZT(3), (I,I=1,16) - 6306 FORMAT (1X,'0.1',1X,F7.3,F7.2,2X,F7.3,F7.2,2X,'L=',I3, & - 15I6) - IF ( KORDER==1 ) WRITE (KW,6307) WINDZF(3), WINDZT(3), & - TOTLZF(3), TOTLZT(3), (I,I=1,16) - 6307 FORMAT (1X,'0.1',1X,F7.3,F7.2,2X,F7.3,F7.2,2X,'K=',I3, & - 15I6) - FRACSL = 0.D0 - IF ( KORDER==0 ) WRITE (KW,6308) TKEFF(1), TKEFF(2), & - TKEFF(3), & - (SRKALB(NORDER(I)),I=1,16), & - BTEMPW, TRUFTW, SRIVIS, SROVIS, & - PLAVIS, SRINIR, SRONIR, PLANIR - IF ( KORDER==1 ) WRITE (KW,6308) TKEFF(1), TKEFF(2), & - TKEFF(3), (SRKALB(I),I=1,16), & - BTEMPW, TRUFTW, SRIVIS, SROVIS, & - PLAVIS, SRINIR, SRONIR, PLANIR - WRITE (KW,6309) TRDFGW, TRUFGW, SRDVIS, SRUVIS, ALBVIS, & - SRDNIR, SRUNIR, ALBNIR - 6309 FORMAT (1X,'At Bot of Atm: ',' TRDFGW=',F6.3,1X, & - &' TRUFGW=',F6.3,2X,' SRDVIS=',F6.2,' SRUVIS=', & - F6.2,' ALBVIS=',F6.4,2X,' SRDNIR=',F6.2, & - &' SRUNIR=',F6.2,' ALBNIR=',F6.4) - WRITE (KW,6310) SRXVIS, SRXNIR, SRTVIS, SRRVIS, SRAVIS, & - SRTNIR, SRRNIR, SRANIR - 6310 FORMAT (1X,'In Atmosphere: ',' SRXVIS=',F6.4,1X, & - &' SRXNIR=',F6.4,2X,' SRTVIS=',F6.4,' SRRVIS=', & - F6.4,' SRAVIS=',F6.4,2X,' SRTNIR=',F6.4, & - &' SRRNIR=',F6.4,' SRANIR=',F6.4) - 6311 FORMAT (' ') - CYCLE - ELSEIF ( INDX==4 ) THEN -! -!------------- -!------------- -! -! (4A) Total Aerosol Qx, Qs, g, Pi0 -! ---------------------------------- - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6401) -! - 6401 FORMAT (' (4A) Aerosol Input for Solar Radiation:', & - &' Aerosol Radiative Parameters',T81, & - &'LIST: SRAEXT(L,K),SRASCT(L,K),SRAGCB(L,K),SRAPI0(L,K)'& - //T42,'TAU -- EXTINCTION',T99,'TAU -- SCATTERING',/T24,& - 53('-'),4X,53('-')) - DO K = 1, 6 - SUM1(K) = 0. - SUM2(K) = 0. - SUM3(K) = 0. - DO L = L1, NL - SUM1(K) = SUM1(K) + WSREXT(L,K) - SUM2(K) = SUM2(K) + WSRSCT(L,K) - SUM3(K) = SUM3(K) + WSRSCT(L,K)*WSRGCB(L,K) - ENDDO - SUM3(K) = SUM3(K)/(SUM2(K)+1.D-10) - SUM0(K) = SUM2(K)/(SUM1(K)+1.D-10) - ENDDO - WRITE (KW,6402) (K,K=1,6), (K,K=1,6) - 6402 FORMAT (' LN PLB HLB K=',I3,5I9,7X,'K=',I3, & - 5I9) - DO L = NL, L1, -1 - WRITE (KW,6403) L, PLB(L), HLB0(L), & - (WSREXT(L,J),J=1,6), & - (WSRSCT(L,J),J=1,6) - 6403 FORMAT (1X,I2,2F8.3,3X,6F9.6,3X,6F9.6) - ENDDO - WRITE (KW,6404) (SUM1(K),K=1,6), (SUM2(K),K=1,6) - 6404 FORMAT (/1X,T7,'COLUMN AMOUNT=',2X,6F9.6,3X,6F9.6) - NPAGE = 0 - IF ( NL>13 ) NPAGE = 1 - WRITE (KW,6405) KANORM - 6405 FORMAT (6X,'KANORM=',1I1/T48,'COSBAR',T105,'PIZERO',/T24,& - 53('-'),4X,53('-')) - WRITE (KW,6406) (K,K=1,6), (K,K=1,6) - 6406 FORMAT (' LN PL DPL K=',I3,5I9,7X,'K=',I3, & - 5I9) - DO L = NL, L1, -1 - WRITE (KW,6407) L, PL(L), DPL(L), (WSRGCB(L,J),J=1,6),& - (WSRPI0(L,J),J=1,6) - 6407 FORMAT (1X,I2,2F8.3,3X,6F9.6,3X,6F9.6) - ENDDO - WRITE (KW,6408) (SUM3(K),K=1,6), (SUM0(K),K=1,6) - 6408 FORMAT (/1X,T7,'COLUMN MEAN=',2X,6F9.6,3X,6F9.6) -! WRITE(KW,6420) (SRBALB(K),K=1,6) -! WRITE(KW,6421) (SRXALB(K),K=1,6) -! WRITE(KW,6422) - SUMT = 0. - DO J = 1, 5 - TAU55 = 0. - DO I = 1, 11 - ! NAERO - TAU55 = TAU55 + AGOLDH(I,J)*FGOLDH(J) - ENDDO - WRITE (KW,6423) J, FGOLDH(J), TAU55 - SUMT = SUMT + TAU55 - ENDDO - WRITE (KW,6438) SUMT - WRITE (KW,6424) BCOLX, ACOLX, DCOLX, VCOLX, TCOLX - 6424 FORMAT (/T11, & - &'SUM COLUMN TAU(0.55) = BkGrnd ClimAer D Dust'& - ,' VolAer TotAer'/T33,5F10.5) - DO I = 1, 8 - WRITE (KW,6425) - ENDDO -! -! (4B) Water/Ice Cloud Qx, Qs, g, Pi0 -! ------------------------------------ - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6411) -! - 6411 FORMAT (' (4B) Cloud Input for Solar Radiation:', & - &' Cloud Radiative Parameters',T81, & - &'LIST: SRCEXT(L,K),SRCSCT(L,K),SRCGCB(L,K),SRCPI0(L,K)'& - //T42,'TAU -- EXTINCTION',T99,'TAU -- SCATTERING',/T24,& - 53('-'),4X,53('-')) - DO K = 1, 6 - SUM1(K) = 0. - SUM2(K) = 0. - SUM3(K) = 0. - DO L = L1, NL - SUM1(K) = SUM1(K) + SRCEXT(L,K) - SUM2(K) = SUM2(K) + SRCSCT(L,K) - SUM3(K) = SUM3(K) + SRCSCT(L,K)*SRCGCB(L,K) - SRCPI0(L,K) = SRCSCT(L,K)/(SRCEXT(L,K)+1.D-10) - ENDDO - SUM3(K) = SUM3(K)/(SUM2(K)+1.D-10) - SUM0(K) = SUM2(K)/(SUM1(K)+1.D-10) - ENDDO - WRITE (KW,6412) (K,K=1,6), (K,K=1,6) - 6412 FORMAT (' LN PLB HLB K=',I3,5I9,7X,'K=',I3, & - 5I9) - DO L = NL, L1, -1 - WRITE (KW,6413) L, PLB(L), HLB0(L), & - (SRCEXT(L,J),J=1,6), & - (SRCSCT(L,J),J=1,6) - 6413 FORMAT (1X,I2,2F8.3,3X,6F9.6,3X,6F9.6) - ENDDO - WRITE (KW,6414) (SUM1(K),K=1,6), (SUM2(K),K=1,6) - 6414 FORMAT (/1X,T7,'COLUMN AMOUNT=',2X,6F9.6,3X,6F9.6) - NPAGE = 0 - IF ( NL>13 ) NPAGE = 1 - WRITE (KW,6415) KANORM - 6415 FORMAT (6X,'KANORM=',1I1/T48,'COSBAR',T105,'PIZERO',/T24,& - 53('-'),4X,53('-')) - WRITE (KW,6416) (K,K=1,6), (K,K=1,6) - 6416 FORMAT (' LN PL DPL K=',I3,5I9,7X,'K=',I3, & - 5I9) - DO L = NL, L1, -1 - WRITE (KW,6417) L, PL(L), DPL(L), (SRCGCB(L,J),J=1,6),& - (SRCPI0(L,J),J=1,6) - 6417 FORMAT (1X,I2,2F8.3,3X,6F9.6,3X,6F9.6) - ENDDO - WRITE (KW,6418) (SUM3(K),K=1,6), (SUM0(K),K=1,6) - 6418 FORMAT (/1X,T7,'COLUMN MEAN=',2X,6F9.6,3X,6F9.6) - WRITE (KW,6420) (SRBALB(K),K=1,6) -! - 6420 FORMAT (/1X,T7,'ALBEDO RSURFB=',2X,6F9.6,3X,6F9.6) - WRITE (KW,6421) (SRXALB(K),K=1,6) - 6421 FORMAT (1X,T7,'ALBEDO RSURFX=',2X,6F9.6,3X,6F9.6) - WRITE (KW,6422) - 6422 FORMAT (///T44,'AEROSOL COMPOSITION AND TYPE MIX:',T81, & - &'FACTOR',6X,'VALUE',T107,'TAU(0.55)'/) - SUMT = 0. - DO J = 1, 5 - TAU55 = 0. - DO I = 1, 11 - ! NAERO - TAU55 = TAU55 + AGOLDH(I,J)*FGOLDH(J) - ENDDO - WRITE (KW,6423) J, FGOLDH(J), TAU55 - SUMT = SUMT + TAU55 - ENDDO - WRITE (KW,6438) SUMT - DO I = 1, 2 - WRITE (KW,6425) - ENDDO -! -! (4C) Aerosol + Cloud Qx, Qs, g, Pi0 -! ------------------------------------ - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6426) -! - 6426 FORMAT (' (4C) Cloud+Aerosol Output from SOLARM/SGPGXG:'& - ,' Cloud+Aerosol Rad Parameters',T81, & - &'LIST: DBLEXT(L,K),DBLSCT(L,K),DBLGCB(L,K),DBLPI0(L,K)'& - //T42,'TAU -- EXTINCTION',T99,'TAU -- SCATTERING',/T24,& - 53('-'),4X,53('-')) - DO K = 1, 6 - SUM1(K) = 0. - SUM2(K) = 0. - SUM3(K) = 0. - DO L = L1, NL - SUM1(K) = SUM1(K) + DBLEXT(L,K) - SUM2(K) = SUM2(K) + DBLSCT(L,K) - SUM3(K) = SUM3(K) + DBLSCT(L,K)*DBLGCB(L,K) - DBLPI0(L,K) = DBLSCT(L,K)/(DBLEXT(L,K)+1.E-10) - ENDDO - SUM3(K) = SUM3(K)/(SUM2(K)+1.E-10) - SUM0(K) = SUM2(K)/(SUM1(K)+1.E-10) - ENDDO - WRITE (KW,6427) (K,K=1,6), (K,K=1,6) - 6427 FORMAT (' LN PLB HLB K=',I3,5I9,7X,'K=',I3, & - 5I9) - DO L = NL, L1, -1 - WRITE (KW,6428) L, PLB(L), HLB0(L), & - (DBLEXT(L,J),J=1,6), & - (DBLSCT(L,J),J=1,6) - 6428 FORMAT (1X,I2,2F8.3,3X,6F9.6,3X,6F9.6) - ENDDO - WRITE (KW,6429) (SUM1(K),K=1,6), (SUM2(K),K=1,6) - 6429 FORMAT (/1X,T7,'COLUMN AMOUNT=',2X,6F9.6,3X,6F9.6) - NPAGE = 0 - IF ( NL>13 ) NPAGE = 1 - WRITE (KW,6430) KANORM - 6430 FORMAT (6X,'KANORM=',1I1/T48,'COSBAR',T105,'PIZERO',/T24,& - 53('-'),4X,53('-')) - WRITE (KW,6431) (K,K=1,6), (K,K=1,6) - 6431 FORMAT (' LN PL DPL K=',I3,5I9,7X,'K=',I3, & - 5I9) - DO L = NL, L1, -1 - WRITE (KW,6432) L, PL(L), DPL(L), (DBLGCB(L,J),J=1,6),& - (DBLPI0(L,J),J=1,6) - 6432 FORMAT (1X,I2,2F8.3,3X,6F9.6,3X,6F9.6) - ENDDO - WRITE (KW,6433) (SUM3(K),K=1,6), (SUM0(K),K=1,6) - 6433 FORMAT (/1X,T7,'COLUMN MEAN=',2X,6F9.6,3X,6F9.6) - WRITE (KW,6434) (SRBALB(K),K=1,6) - 6434 FORMAT (/1X,T7,'ALBEDO RSURFB=',2X,6F9.6,3X,6F9.6) - WRITE (KW,6435) (SRXALB(K),K=1,6) - 6435 FORMAT (1X,T7,'ALBEDO RSURFX=',2X,6F9.6,3X,6F9.6) - WRITE (KW,6436) - 6436 FORMAT (///T44,'AEROSOL COMPOSITION AND TYPE MIX:',T81, & - &'FACTOR',6X,'VALUE',T107,'TAU(0.55)'/) - SUMT = 0. - DO J = 1, 5 - TAU55 = 0. - DO I = 1, 11 - ! NAERO - TAU55 = TAU55 + AGOLDH(I,J)*FGOLDH(J) - ENDDO - WRITE (KW,6437) J, FGOLDH(J), TAU55 - 6437 FORMAT (T81,'FGOLDH(',I1,') =',1P,E9.2,5X,0P,F7.4) - SUMT = SUMT + TAU55 - ENDDO - WRITE (KW,6438) SUMT - DO I = 1, 2 - WRITE (KW,6439) - 6439 FORMAT (' ') - ENDDO -! -! (4D) 11-Comp Aerosol Qx, Qs, g, Pi0 -! ------------------------------------ - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6440) KWTRAB, (N,N=1,11) -! - 6440 FORMAT (' (4D) Background Aerosol Solar and Thermal Mie '& - ,'Scattering Parameters:',T81, & - &'List: SRAQEX(L,K),SRAQST(L,K),SRAQCB(L,K), TRAB Q S G'& - /' KWTRAB=',I1/7X,11I8/ & - &' AEROSOL ACID1 SSALT SLFT1 SLFT2 BSLT1', & - &' BSLT2 DUST1 DUST2 DUST3 CARB1 CARB2'/ & - &' SIZE 0.5 2.0 0.3 1.0 0.5 ', & - &' 2.0 0.5 2.0 8.0 0.1 0.5 ') - WRITE (KW,6441) - 6441 FORMAT (' K SRAQEX') - DO K = 1, 6 - WRITE (KW,6442) K, (SRAQEX(K,N),N=1,11) - ENDDO - WRITE (KW,6443) - 6443 FORMAT (' K SRAQSC') - DO K = 1, 6 - WRITE (KW,6442) K, (SRAQSC(K,N),N=1,11) - ENDDO - WRITE (KW,6444) - 6444 FORMAT (' K SRAQCB') - DO K = 1, 6 - WRITE (KW,6442) K, (SRAQCB(K,N),N=1,11) - ENDDO - WRITE (KW,6445) TRABCD(1), TRAXSG(KWTRAB+1) - 6445 FORMAT (' K ',2A3) - DO K = 1, 33 - IF ( KWTRAB==0 ) WRITE (KW,6442) K, & - (TRAQAB(K,N),N=1,11) - IF ( KWTRAB==1 ) WRITE (KW,6442) K, & - (TRAQEX(K,N),N=1,11) - IF ( KWTRAB==2 ) WRITE (KW,6442) K, & - (TRAQSC(K,N),N=1,11) - IF ( KWTRAB==3 ) WRITE (KW,6442) K, & - (TRAQCB(K,N),N=1,11) - IF ( KWTRAB==4 ) THEN - DO N = 1, 11 - TRPI0K(N) = TRAQSC(K,N)/(1.D-10+TRAQEX(K,N)) - ENDDO - WRITE (KW,6442) K, (TRPI0K(N),N=1,11) - ENDIF - ENDDO - DO I = 1, 1 - WRITE (KW,6446) - 6446 FORMAT (' ') - ENDDO -! -! -! (4E) 10-Comp Aerosol Qx, Qs, g, Pi0 -! ------------------------------------ - WRITE (KW,6450) KWTRAB, (N,N=1,6), (REFDRY(N),N=1,6) -! - 6450 FORMAT ( & - &' (4E) Climatology Aerosol Solar and Thermal Mie '& - ,'Scattering Parameters:',T81, & - &'List: SRBQEX(L,K),SRBQST(L,K),SRBQCB(L,K), TRAB Q S G'& - /' KWTRAB=',I1/7X, & - &6I8/' AEROSOL SO4 SEA ANT OCX BCI '& - ,' BCB'/' SIZE ',6F8.1) - ! OCN OCB BCB SSB - WRITE (KW,6451) - 6451 FORMAT (' K SRBQEX - DRY') - DO K = 1, 6 - WRITE (KW,6452) K, (SRHQEX(K,1,N),N=1,4), & - (SRBQEX(K,N),N=5,6) - ENDDO - WRITE (KW,6453) - 6453 FORMAT (' K SRBQSC - DRY') - DO K = 1, 6 - WRITE (KW,6452) K, (SRHQSC(K,1,N),N=1,4), & - (SRBQSC(K,N),N=5,6) - ENDDO - WRITE (KW,6454) - 6454 FORMAT (' K SRBQCB - DRY') - DO K = 1, 6 - WRITE (KW,6452) K, (SRHQCB(K,1,N),N=1,4), & - (SRBQCB(K,N),N=5,6) - ENDDO - WRITE (KW,6455) TRABCD(2), TRAXSG(1) - !obs TRAXSG(KWTRAB+1) - 6455 FORMAT (' K ',2A3,' - DRY') - DO K = 1, 33 - IF ( KWTRAB==0 ) WRITE (KW,6442) K, & - (TRHQAB(K,1,N),N=1,4), (TRBQAB(K,N),N=5,6) -!obs IF(KWTRAB==1) WRITE(KW,6442) K,(TRHQEX(K,1,N),N=1, 4), -!obs * (TRBQEX(K,N),N=5, 6) -!obs IF(KWTRAB==2) WRITE(KW,6442) K,(TRHQSC(K,1,N),N=1, 4), -!obs * (TRBQSC(K,N),N=5, 6) -!obs IF(KWTRAB==3) WRITE(KW,6442) K,(TRHQCB(K,1,N),N=1, 4), -!obs * (TRBQCB(K,N),N=5, 6) -!obs IF(KWTRAB==4) THEN -!obs DO N=1,4 -!obs TRPI0K(N)=TRHQCB(K,1,N)/(1.D-10+TRHQEX(K,1,N)) -!obs END DO -!obs DO N=5,6 ! 10 -!obs TRPI0K(N)=TRBQSC(K,N)/(1.D-10+TRBQEX(K,N)) -!obs END DO -!obs WRITE(KW,6442) K,(TRPI0K(N),N=1, 6) -!obs ENDIF - ENDDO - DO I = 1, 1 - WRITE (KW,6456) - 6456 FORMAT (' ') - ENDDO -! -! (4F 8-size Dust Aerosol Qx, Qs, g, Pi0 -! --------------------------------------- - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6460) KWTRAB, (N,N=1,8), (REDUST(N),N=1,8) -! - 6460 FORMAT ( & - &' (4F) Desert Dust Aerosol Solar and Thermal Mie '& - ,'Scattering Parameters:',T81, & - &'List: SRDQEX(L,K),SRDQST(L,K),SRDQCB(L,K), TRAB Q S G'& - /' KWTRAB=',I1/7X, & - &8I8/' AEROSOL CLAY1 CLAY2 CLAY3 CLAY4 SILT1'& - ,' SILT2 SILT3 SILT4 '/ & - &' SIZE ',8F8.1) - WRITE (KW,6461) - 6461 FORMAT (' K SRDQEX') - DO K = 1, 6 - WRITE (KW,6462) K, (SRAQEX(K,N),N=1,8) - ENDDO - WRITE (KW,6463) - 6463 FORMAT (' K SRDQSC') - DO K = 1, 6 - WRITE (KW,6462) K, (SRAQSC(K,N),N=1,8) - ENDDO - WRITE (KW,6464) - 6464 FORMAT (' K SRDQCB') - DO K = 1, 6 - WRITE (KW,6462) K, (SRAQCB(K,N),N=1,8) - ENDDO - WRITE (KW,6465) TRABCD(4), TRAXSG(KWTRAB+1) - 6465 FORMAT (' K ',2A3) - DO K = 1, 33 - IF ( KWTRAB==0 ) WRITE (KW,6442) K, & - (TRDQAB(K,N),N=1,8) - IF ( KWTRAB==1 ) WRITE (KW,6442) K, & - (TRDQEX(K,N),N=1,8) - IF ( KWTRAB==2 ) WRITE (KW,6442) K, & - (TRDQSC(K,N),N=1,8) - IF ( KWTRAB==3 ) WRITE (KW,6442) K, & - (TRDQCB(K,N),N=1,8) - IF ( KWTRAB==4 ) THEN - DO N = 1, 8 - TRPI0K(N) = TRDQSC(K,N)/(1.D-10+TRDQEX(K,N)) - ENDDO - WRITE (KW,6442) K, (TRPI0K(N),N=1,8) - ENDIF - ENDDO - DO I = 1, 1 - WRITE (KW,6466) - 6466 FORMAT (' ') - ENDDO -! -! (4G 15-Size/phase Cloud Qx, Qs, g, Pi0 -! --------------------------------------- - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE - WRITE (KW,6470) KWTRAB, (N,N=1,15) -! - 6470 FORMAT (' (4G) Cloud Input for Solar, Thermal Radiation:'& - ,' Mie Cloud Radiative Properties',T81, & - &'List: SRCQEX(L,K),SRCQST(L,K),SRCQCB(L,K), TRAB Q S G'& - /' KWTRAB=',I1/7X,15I8/ & - &' WIM CLOUD WAT05 WAT10 WAT15 WAT20 WAT25', & - &' ICE05 ICE15 ICE25 ICE50 ICE75', & - &' MIC05 MIC15 MIC25 MIC50 MIC75') - WRITE (KW,6471) - 6471 FORMAT (' K SRCQEX') - DO K = 1, 6 - WRITE (KW,6472) K, (SRCQEX(K,N),N=1,15) - ENDDO - WRITE (KW,6473) - 6473 FORMAT (' K SRCQSC') - DO K = 1, 6 - WRITE (KW,6472) K, (SRCQSC(K,N),N=1,15) - ENDDO - WRITE (KW,6474) - 6474 FORMAT (' K SRCQCB') - DO K = 1, 6 - WRITE (KW,6472) K, (SRCQCB(K,N),N=1,15) - ENDDO - WRITE (KW,6475) TRABCD(3), TRAXSG(KWTRAB+1) - 6475 FORMAT (' K ',2A3) - DO K = 1, 33 - IF ( KWTRAB==0 ) WRITE (KW,6472) K, & - (TRCQAB(K,N),N=1,15) - IF ( KWTRAB==1 ) WRITE (KW,6472) K, & - (TRCQEX(K,N),N=1,15) - IF ( KWTRAB==2 ) WRITE (KW,6472) K, & - (TRCQSC(K,N),N=1,15) - IF ( KWTRAB==3 ) WRITE (KW,6472) K, & - (TRCQCB(K,N),N=1,15) - IF ( KWTRAB==4 ) THEN - DO N = 1, 15 - TRPI0K(N) = TRCQSC(K,N)/(1.D-10+TRCQEX(K,N)) - ENDDO - WRITE (KW,6442) K, (TRPI0K(N),N=1,15) - ENDIF - ENDDO - DO I = 1, 2 - WRITE (KW,6476) - 6476 FORMAT (' ') - ENDDO - CYCLE - ELSEIF ( INDX==5 ) THEN -! -!------------- -!------------- -! - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE -! SIGMA=5.6697D-08 - TGMEAN = POCEAN*TGO**4 + PEARTH*TGE**4 + PLICE*TGLI**4 + & - POICE*TGOI**4 - TGMEAN = SQRT(TGMEAN) - TGMEAN = SQRT(TGMEAN) - SIGT4 = SIGMA*TGMEAN**4 - ITG = TGMEAN - WTG = TGMEAN - ITG - SUMK = 0.0 - DO K = 1, 33 - BGFLUX(K) = PLANCK(ITG,K) & - - (PLANCK(ITG,K)-PLANCK(ITG+1,K))*WTG - BGFRAC(K) = BGFLUX(K)/SIGT4 - SUMK = SUMK + BGFLUX(K) - ENDDO - LK = 0 - DO K = 1, 33 - TAUSUM(K) = 0. - !!sl TAUSL(K) - DO L = L1, NL - TRTAUK(L,K) = TRGXLK(L,K) + TRCALK(L,K) & - + TRAALK(L,K) - TAUSUM(K) = TAUSUM(K) + TRGXLK(L,K) + TRCALK(L,K) & - + TRAALK(L,K) - ENDDO - ENDDO - WRITE (KW,6501) -! - 6501 FORMAT (' (5) TAU TABLE FOR THERMAL RADIATION: CONTAINS',& - &' TOTAL SPECIFIED GAS, CLOUD AEROSOL ABSORPTION'& - ,T99,'TRGXLK(L,K),TRCALK(L,K),TRCAAK(L,K)'/,/1X, & - &'K-DIST BREAKDOWN:',T23,'WINDOW',3X, & - 'WATER VAPOR:',T71,'PRINCIPAL ABSORBER REGION', & - /T23,6('-'),3X,101('-')) - WRITE (KW,6502) (K,K=1,13) - 6502 FORMAT (' LN PL TLM K=',I1,4X,'K=',I2,9I9, & - 3I8) - DO L = NL, L1, -1 - WRITE (KW,6503) L, PL(L), TLM(L), (TRTAUK(L,K),K=1,13) - 6503 FORMAT (1X,I2,F8.3,F7.2,1X,10F9.4,3F8.3) - ENDDO -!sl WRITE(KW,6504) (TAUSL(K),K=1,13) - WRITE (KW,6505) (TAUSUM(K),K=1,13) -!sl6504 FORMAT(/4X,'SURFACE LAYER= ',10F9.4,3F8.3) - 6505 FORMAT (4X,'COLUMN AMOUNT= ',10F9.4,3F8.3) - WRITE (KW,6506) SUMK, (BGFLUX(K),K=1,13) - 6506 FORMAT (/1X,'PF W/M**2= ',F6.2,1X,10F9.3,3F8.3) - WRITE (KW,6507) TGMEAN, SIGT4, (BGFRAC(K),K=1,13) - 6507 FORMAT (1X,'TG=',F6.2,'= ',F6.2,1X,10F9.4,3F8.3) - NPAGE = 0 - IF ( NL>13 ) NPAGE = 1 - WRITE (KW,6508) NPAGE - 6508 FORMAT (1I1/4X,'CARBON DIOXIDE:',T36, & - &'PRINCIPAL ABSORBER REGION',T83,'OZONE:',T100, & - &'PRINCIPAL ABSORBER REGION'/4X,76('-'),2X,50('-')& - ) - WRITE (KW,6509) (K,K=14,33) - 6509 FORMAT (1X,'LN K=',I2,5I7,6I6,3X,'K=',I2,3I7,6I6) - DO L = NL, L1, -1 - WRITE (KW,6510) L, (TRTAUK(L,K),K=14,33) - 6510 FORMAT (1X,I2,6F7.4,2F6.3,3F6.2,1F6.1,4F7.4,3F6.3, & - F6.2) - ENDDO -!sl WRITE(KW,6511) ( TAUSL(K),K=14,33) - WRITE (KW,6512) (TAUSUM(K),K=14,33) -!sl6511 FORMAT(/1X,'SL',6F7.4,2F6.3,3F6.2,1F6.1,4F7.4,3F6.3,F6.2) - 6512 FORMAT (1X,'CA',5F7.4,1F7.3,3F6.2,2F6.1,1F6.0,4F7.4, & - 2F6.3,2F6.2) - WRITE (KW,6513) (BGFLUX(K),K=14,33) - 6513 FORMAT (/1X,'PF',1F7.4,5F7.3,1F6.2,3F6.3,2F6.3,2F7.3, & - 2F7.4,4F6.3) - WRITE (KW,6514) (BGFRAC(K),K=14,33) - 6514 FORMAT (1X,'FR',6F7.4,2F6.3,3F6.3,1F6.3,4F7.4,3F6.3,F6.3) - DO I = 1, 10 - WRITE (KW,6515) - 6515 FORMAT (' ') - ENDDO - CYCLE - ELSEIF ( INDX==6 ) THEN -! -!------------- -!------------- -! - NPAGE = 1 - IF ( INDEX<11 ) NPAGE = KPAGE -! SIGMA=5.6697D-08 - TGMEAN = POCEAN*TGO**4 + PEARTH*TGE**4 + PLICE*TGLI**4 + & - POICE*TGOI**4 - TGMEAN = SQRT(TGMEAN) - TGMEAN = SQRT(TGMEAN) - SIGT4 = SIGMA*TGMEAN**4 - ITG = TGMEAN - WTG = TGMEAN - ITG - SUMK = 0.0 - DO K = 1, 33 - BGFLUX(K) = PLANCK(ITG,K) & - - (PLANCK(ITG,K)-PLANCK(ITG+1,K))*WTG - BGFRAC(K) = BGFLUX(K)/SIGT4 - SUMK = SUMK + BGFLUX(K) - ENDDO - WRITE (KW,6601) -! - 6601 FORMAT ( & - &' (6) TAU TABLE FOR THERMAL RADIATION: INCLUDES ANY'& - ,' SPECIFIED OVERLAP, CLOUD AEROSOL ABSORPTION', & - T114,'TRGXLK(L,K),TAUSL(L)'/,/1X, & - 'K-DIST BREAKDOWN:',T23,'WINDOW',3X,'WATER VAPOR:', & - T71,'PRINCIPAL ABSORBER REGION',/T23,6('-'),3X, & - &101('-')) - WRITE (KW,6602) (K,K=1,13) - 6602 FORMAT (' LN PL TLM K=',I1,4X,'K=',I2,9I9, & - 3I8) - DO L = NL, L1, -1 - WRITE (KW,6603) L, PL(L), TLM(L), (TRGXLK(L,K),K=1,13) - 6603 FORMAT (1X,I2,F8.3,F7.2,1X,10F9.4,3F8.3) - ENDDO - LK = 0 - DO K = 1, 33 - TAUSUM(K) = 0. - !!sl TAUSL(K) - DO L = L1, NL - TAUSUM(K) = TAUSUM(K) + TRGXLK(L,K) - ENDDO - ENDDO -!sl WRITE(KW,6604) (TAUSL(K),K=1,13) - WRITE (KW,6605) (TAUSUM(K),K=1,13) - 6605 FORMAT (4X,'COLUMN AMOUNT= ',10F9.4,3F8.3) - WRITE (KW,6606) SUMK, (BGFLUX(K),K=1,13) - 6606 FORMAT (/1X,'PF W/M**2= ',F6.2,1X,10F9.3,3F8.3) - WRITE (KW,6607) TGMEAN, SIGT4, (BGFRAC(K),K=1,13) - 6607 FORMAT (1X,'TG=',F6.2,'= ',F6.2,1X,10F9.4,3F8.3) - NPAGE = 0 - IF ( NL>13 ) NPAGE = 1 - WRITE (KW,6608) - 6608 FORMAT (/4X,'CARBON DIOXIDE:',T36, & - &'PRINCIPAL ABSORBER REGION',T83,'OZONE:',T100, & - &'PRINCIPAL ABSORBER REGION'/4X,76('-'),2X,50('-')& - ) - WRITE (KW,6609) (K,K=14,33) - 6609 FORMAT (1X,'LN K=',I2,5I7,6I6,3X,'K=',I2,3I7,6I6) - DO L = NL, L1, -1 - WRITE (KW,6610) L, (TRGXLK(L,K),K=14,33) - 6610 FORMAT (1X,I2,6F7.4,2F6.3,3F6.2,1F6.1,4F7.4,3F6.3, & - F6.2) - ENDDO -!sl WRITE(KW,6611) ( TAUSL(K),K=14,33) - WRITE (KW,6612) (TAUSUM(K),K=14,33) -!sl6611 FORMAT(/1X,'SL',6F7.4,2F6.3,3F6.2,1F6.1,4F7.4,3F6.3,F6.2) - 6612 FORMAT (1X,'CA',5F7.4,1F7.3,3F6.2,2F6.1,1F6.0,4F7.4, & - 2F6.3,2F6.2) - WRITE (KW,6613) (BGFLUX(K),K=14,33) - 6613 FORMAT (/1X,'PF',1F7.4,5F7.3,1F6.2,3F6.3,2F6.3,2F7.3, & - 2F7.4,4F6.3) - WRITE (KW,6614) (BGFRAC(K),K=14,33) - 6614 FORMAT (1X,'FR',6F7.4,2F6.3,3F6.3,1F6.3,4F7.4,3F6.3,F6.3) - DO I = 1, 10 - WRITE (KW,6615) - 6615 FORMAT (' ') - ENDDO - 6604 FORMAT (/4X,'SURFACE LAYER= ',10F9.4,3F8.3) - CYCLE - ELSEIF ( INDX==7 ) THEN -! -!------------- -!------------- -! -! SIGMA=5.6697D-08 - TGMEAN = POCEAN*TGO**4 + PEARTH*TGE**4 + PLICE*TGLI**4 + & - POICE*TGOI**4 - TGMEAN = SQRT(TGMEAN) - TGMEAN = SQRT(TGMEAN) - SIGT4 = SIGMA*TGMEAN**4 - ITG = TGMEAN - WTG = TGMEAN - ITG - SUMK = 0.0 - DO K = 1, 33 - BGFLUX(K) = PLANCK(ITG,K) & - - (PLANCK(ITG,K)-PLANCK(ITG+1,K))*WTG - BGFRAC(K) = BGFLUX(K)/SIGT4 - SUMK = SUMK + BGFLUX(K) - ENDDO - WRITE (KW,6701) -! - 6701 FORMAT ( & - &' (7A) TRCALK TABLE FOR THERMAL RADIATION: CONTAINS'& - ,' 33 KD CLOUD ABSORPTION OPTICAL DEPTHS AT', & - &' THERMAL WAVELENGTHS ',T117,'LIST: TRCALK(L,K)'/, & - /1X,'K-DIST BREAKDOWN:',T23,'WINDOW',3X, & - &'WATER VAPOR:',T71,'PRINCIPAL ABSORBER REGION',/T23,& - 6('-'),3X,101('-')) - WRITE (KW,6702) (K,K=1,13) - 6702 FORMAT (' LN PL TLM K=',I1,6X,I2,9I9,3I8) - DO L = NL, L1, -1 - WRITE (KW,6703) L, PL(L), TLM(L), (TRCALK(L,K),K=1,13) - 6703 FORMAT (1X,I2,F8.3,F7.2,1X,9F9.5,4F8.5) - ENDDO - LK = 0 - DO K = 1, 33 - TAUSUM(K) = 0.0 - DO L = L1, NL - LK = LK + 1 - TAUSUM(K) = TAUSUM(K) + TRCALK(L,K) - ENDDO - ENDDO - WRITE (KW,6704) (TAUSUM(K),K=1,13), (TRCTCA(K),K=1,13) - 6704 FORMAT (/4X,'COLUMN AMOUNT= ',9F9.4,4F8.5/4X, & - &'TOPCLD ALBEDO= ',9F9.4,4F8.5) - WRITE (KW,6705) - 6705 FORMAT (/' K-INTERVAL CONTRIBUTIONS:'/ & - &' COMPARE WITH GROUND FLUX:') - WRITE (KW,6706) SUMK, (BGFLUX(K),K=1,13) - 6706 FORMAT (1X,'PF W/M**2= ',F6.2,1X,10F9.3,3F8.3) - WRITE (KW,6707) TGMEAN, SIGT4, (BGFRAC(K),K=1,13) - 6707 FORMAT (1X,'TG=',F6.2,'= ',F6.2,1X,10F9.4,3F8.3) -! - WRITE (KW,6708) - 6708 FORMAT (/T25, & - &'CARBON DIOXIDE: PRINCIPAL ABSORBER REGION', & - T93,'OZONE: PRINCIPAL ABSORBER REGION'/4X, & - &77('-'),1X,51('-')) - WRITE (KW,6709) (K,K=14,33) - 6709 FORMAT (1X,'LN K=',I2,5I7,6I6,3X,'K=',I2,3I7,6I6) - DO L = NL, L1, -1 - WRITE (KW,6710) L, (TRCALK(L,K),K=14,33) - 6710 FORMAT (1X,I2,6F7.4,5F6.4,F6.4,4F7.4,3F6.4,F6.4) - ENDDO - WRITE (KW,6711) (TAUSUM(K),K=14,33), (TRCTCA(K),K=14,33) - 6711 FORMAT (/1X,'CA',5F7.4,1F7.3,3F6.2,2F6.1,1F6.0,4F7.4, & - 2F6.3,2F6.2/1X,'TA',5F7.4,1F7.4,3F6.3,2F6.3, & - 1F6.3,4F7.4,2F6.3,2F6.3) - WRITE (KW,6712) (BGFLUX(K),K=14,33) - 6712 FORMAT (/1X,'PF',1F7.4,5F7.3,1F6.2,3F6.3,2F6.3,2F7.3, & - 2F7.4,4F6.3) - WRITE (KW,6713) (BGFRAC(K),K=14,33) - 6713 FORMAT (1X,'FR',6F7.4,2F6.3,3F6.3,1F6.3,4F7.4,3F6.3,F6.3) - DO I = 1, 8 - WRITE (KW,6714) - 6714 FORMAT (' ') - ENDDO -! -! SIGMA=5.6697D-08 - TGMEAN = POCEAN*TGO**4 + PEARTH*TGE**4 + PLICE*TGLI**4 + & - POICE*TGOI**4 - TGMEAN = SQRT(TGMEAN) - TGMEAN = SQRT(TGMEAN) - SIGT4 = SIGMA*TGMEAN**4 - ITG = TGMEAN - WTG = TGMEAN - ITG - SUMK = 0.0 - DO K = 1, 33 - BGFLUX(K) = PLANCK(ITG,K) & - - (PLANCK(ITG,K)-PLANCK(ITG+1,K))*WTG - BGFRAC(K) = BGFLUX(K)/SIGT4 - SUMK = SUMK + BGFLUX(K) - ENDDO - WRITE (KW,6721) -! - 6721 FORMAT (' (7B) AEROSOL TAU TABLE FOR THERMAL RADIATION:',& - &' AEROSOL ABSORPTION OPTICAL DEPTH AT THERMAL WAVELENGTHS'& - ,T116,'LIST: TRAALK(L,K)'/,/1X,'K-DIST BREAKDOWN:',T23, & - &'WINDOW',3X,'WATER VAPOR:',T71,'PRINCIPAL ABSORBER REGION',& - /T23,6('-'),3X,101('-')) - WRITE (KW,6722) (K,K=1,13) - 6722 FORMAT (' LN PL TLM K=',I1,6X,I2,9I9,3I8) - DO L = NL, L1, -1 - WRITE (KW,6723) L, PL(L), TLM(L), (TRAALK(L,K),K=1,13) - 6723 FORMAT (1X,I2,F8.3,F7.2,1X,10F9.5,3F8.5) - ENDDO - DO K = 1, 33 - TAUSUM(K) = 0.0 - DO L = L1, NL - TAUSUM(K) = TAUSUM(K) + TRAALK(L,K) - ENDDO - ENDDO - WRITE (KW,6724) (TAUSUM(K),K=1,13) - 6724 FORMAT (/4X,'COLUMN AMOUNT= ',10F9.5,3F8.5) - WRITE (KW,6725) - 6725 FORMAT (' K-INTERVAL CONTRIBUTIONS:'/ & - &' COMPARE WITH GROUND FLUX:') - WRITE (KW,6726) SUMK, (BGFLUX(K),K=1,13) - 6726 FORMAT (1X,'PF W/M**2= ',F6.2,1X,10F9.3,3F8.3) - WRITE (KW,6727) TGMEAN, SIGT4, (BGFRAC(K),K=1,13) - 6727 FORMAT (1X,'TG=',F6.2,'= ',F6.2,1X,10F9.4,3F8.3) - NPAGE = 0 - IF ( NL>13 ) NPAGE = 1 - WRITE (KW,6728) NPAGE - 6728 FORMAT (1I1/4X,'CARBON DIOXIDE:',T36, & - &'PRINCIPAL ABSORBER REGION',T83,'OZONE:',T100, & - &'PRINCIPAL ABSORBER REGION'/4X,76('-'),2X,50('-')& - ) - WRITE (KW,6729) (K,K=14,33) - 6729 FORMAT (1X,'LN K=',I2,5I7,6I6,3X,'K=',I2,3I7,6I6) - DO L = NL, L1, -1 - WRITE (KW,6730) L, (TRAALK(L,K),K=14,33) - 6730 FORMAT (1X,I2,6F7.5,2F6.4,3F6.4,F6.4,4F7.4,3F6.4,F6.4) - ENDDO - WRITE (KW,6731) (TAUSUM(K),K=14,33) - 6731 FORMAT (1X,'CA',5F7.5,1F7.5,3F6.4,2F6.4,1F6.4,4F7.4, & - 2F6.4,2F6.4) - WRITE (KW,6732) (BGFLUX(K),K=14,33) - 6732 FORMAT (/1X,'PF',1F7.4,5F7.3,1F6.2,3F6.3,2F6.3,2F7.3, & - 2F7.4,4F6.3) - WRITE (KW,6733) (BGFRAC(K),K=14,33) - 6733 FORMAT (1X,'FR',6F7.4,2F6.3,3F6.3,1F6.3,4F7.4,3F6.3,F6.3) - DO I = 1, 12 - WRITE (KW,6734) - 6734 FORMAT (' ') - ENDDO - CYCLE - ELSEIF ( INDX==8 ) THEN -! -!------------- -!------------- -! - WRITE (KW,6800) -! - 6800 FORMAT ( & - &' (8A) SPECTRAL/k-DISTRIBUTION COMPONENT BREAKDOWN'& - ,' FOR DOWNWARD AND UPWARD SOLAR RADIATIVE FLUXES', & - T108,'SKDFLB(L,K) SKUFLB(L,K) SRKALB(K)'/) - DO K = 1, 16 - ISR1(K) = NORDER(K) - IF ( KORDER==1 ) ISR1(K) = K - ENDDO - WRITE (KW,6801) (ISR1(K),K=1,16) - 6801 FORMAT (' K=',I5,2I8,2I7,I8,I9,7I8,I7,I8, & - &' Total') - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = DKS0(NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = DKS0(K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6802) (FSR1(K),K=1,17) - 6802 FORMAT (' DKS0=',F6.3,2F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3, & - F8.3,F11.3) - DO K = 1, 16 - ISR1(K) = NMWAVA(K) - IF ( KORDER==1 ) ISR1(K) = NMWAVA(IORDER(K)) - ENDDO - WRITE (KW,6803) (ISR1(K),K=1,16) - 6803 FORMAT (' NMWAVA=',I6,2I8,2I7,I8,I9,7I8,I7,I8) - DO K = 1, 16 - ISR1(K) = NMWAVB(K) - IF ( KORDER==1 ) ISR1(K) = NMWAVB(IORDER(K)) - ENDDO - WRITE (KW,6804) (ISR1(K),K=1,16) - 6804 FORMAT (' NMWAVB=',I6,2I8,2I7,I8,I9,7I8,I7,I8) - IF ( KORDER==0 ) WRITE (KW,6805) - 6805 FORMAT (' ABSORB'/ & - &' GAS= O3,O2 O3,NO2 O2 O2 O2', & - &' H2O',22X, & - &'H2O H2O H2O H2O CO2', & - &' CO2 CO2 CO2,H2O,O2'/ & - &' SKDFLB (Downward Spectral Flux)'/6X,6('-'), & - &'VIS',6('-'),2X,46('-'),'NIR',59('-')) - IF ( KORDER==1 ) WRITE (KW,6806) - 6806 FORMAT (' ABSORB'/ & - &' GAS= H2O H2O H2O H2O H2O', & - &' O2 O2 O2 CO2 CO2 CO2'& - ,18X,'O3,NO2 O3,O2 CO2,H2O,O2'/ & - &'SKDFLB (Downard Spectral',' Flux)',T110,6('-'), & - &'VIS',5('-')) - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6807) (ISR1(K),K=1,16) - 6807 FORMAT (' N L=',I4,I9,I8,2I7,I8,I9,7I8,I7,I8, & - &' Total') - DO L = NL + 1, L1, -1 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SKDFLB(L,NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SKDFLB(L,K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6808) L, (FSR1(K),K=1,17) - 6808 FORMAT (I3,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3,F8.3,& - F11.3) - ENDDO - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6809) (ISR1(K),K=1,16) - 6809 FORMAT (/' SKUFLB (Upward Spectral Flux)'/' N L=',I4, & - I9,I8,2I7,I8,I9,7I8,I7,I8,' Total') - DO L = NL + 1, L1, -1 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SKUFLB(L,NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SKUFLB(L,K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6810) L, (FSR1(K),K=1,17) - 6810 FORMAT (I3,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3,F8.3,& - F11.3) - ENDDO - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6811) (ISR1(K),K=1,16) - 6811 FORMAT (/' SRKALB ',I4,I9,I8,2I7,I8,I9,7I8,I7,I8, & - &' Total') - SUMT = 0.D0 - SUMK = 0.D0 - DO K = 1, 16 - FSR1(K) = SRKALB(NORDER(K)) - FSR2(K) = DKS0(NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SRKALB(K) - IF ( KORDER==1 ) FSR2(K) = DKS0(K) - SUMK = SUMK + FSR1(K)*FSR2(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6812) (FSR1(K),K=1,17) - 6812 FORMAT (' TOA=',F5.4,F9.4,F8.4,2F7.4,F8.4,F9.4,7F8.4, & - F7.4,F8.4,F11.4) - SUMT = SUMT + FSR1(17) - SUMK1 = 0.D0 - SUMK2 = 0.D0 - DO K = 1, 16 - FSR1(K) = SKNFLB(NL+1,NORDER(K)) & - - SKNFLB(L1,NORDER(K)) - FSR2(K) = SKDFLB(NL+1,NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SKNFLB(NL+1,K) & - - SKNFLB(L1,K) - IF ( KORDER==1 ) FSR2(K) = SKDFLB(NL+1,K) - SUMK1 = SUMK1 + FSR1(K) - SUMK2 = SUMK2 + FSR2(K) - FSR1(K) = FSR1(K)/(FSR2(K)+1.D-20) - ENDDO - FSR1(17) = SUMK1/(SUMK2+1.D-20) - WRITE (KW,6813) (FSR1(K),K=1,17) - 6813 FORMAT (' ABSORB'/' ATMO=',F5.4,F9.4,F8.4,2F7.4,F8.4, & - F9.4,7F8.4,F7.4,F8.4,F11.4) - SUMT = SUMT + FSR1(17) - SUMK1 = 0.D0 - SUMK2 = 0.D0 - DO K = 1, 16 - FSR1(K) = SKNFLB(L1,NORDER(K)) - FSR2(K) = SKDFLB(NL+1,NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SKNFLB(L1,K) - IF ( KORDER==1 ) FSR2(K) = SKDFLB(NL+1,K) - SUMK1 = SUMK1 + FSR1(K) - SUMK2 = SUMK2 + FSR2(K) - FSR1(K) = FSR1(K)/(FSR2(K)+1.D-20) - ENDDO - FSR1(17) = SUMK1/(SUMK2+1.D-20) - WRITE (KW,6814) (FSR1(K),K=1,17) - 6814 FORMAT (' ABSORB'/' SURF=',F5.4,F9.4,F8.4,2F7.4,F8.4, & - F9.4,7F8.4,F7.4,F8.4,F11.4) - SUMT = SUMT + FSR1(17) - DO K = 1, 16 - ISR1(K) = KSLAMW(NORDER(K)) - IF ( KORDER==1 ) ISR1(K) = KSLAMW(K) - ENDDO - WRITE (KW,6815) SUMT, (ISR1(K),K=1,16) - 6815 FORMAT (' ALSURF',T133,'Sum=',F6.4/' KSLAM= ',I3,I9,I8, & - 2I7,I8,I9,7I8,I7,I8) - SUMK = 0.D0 - DO K = 1, 16 - KK = KSLAMW(NORDER(K)) - IF ( KORDER==1 ) KK = KSLAMW(K) - FSR1(K) = SRBALB(KK) - FSR2(K) = SRXALB(KK) - ENDDO - WRITE (KW,6816) (FSR1(K),K=1,16) - 6816 FORMAT (' SRX=',F5.4,F9.4,F8.4,2F7.4,F8.4,F9.4,7F8.4, & - F7.4,F8.4,F11.4) - WRITE (KW,6817) (FSR2(K),K=1,16) - 6817 FORMAT (' SRB=',F5.4,F9.4,F8.4,2F7.4,F8.4,F9.4,7F8.4, & - F7.4,F8.4,F11.4) - WRITE (KW,6818) COSZ, SRIVIS, SROVIS, PLAVIS, SRINIR, & - SRONIR, PLANIR - 6818 FORMAT (/' At Top of Atm: ',' COSZ =',F6.4,14X,2X, & - &' SRIVIS=',F7.3,' SROVIS=',F7.3,' PLAVIS=', & - F6.4,2X,' SRINIR=',F7.3,' SRONIR=',F7.3, & - &' PLANIR=',F6.4) - WRITE (KW,6819) SRXVIS, SRXNIR, SRDVIS, SRUVIS, ALBVIS, & - SRDNIR, SRUNIR, ALBNIR - 6819 FORMAT (' At Bot of Atm: ',' SRXVIS=',F6.4,1X, & - ' SRXNIR=',F6.4,1X,' SRDVIS=',F7.3,' SRUVIS=', & - F7.3,' ALBVIS=',F6.4,2X,' SRDNIR=',F7.3, & - &' SRUNIR=',F7.3,' ALBNIR=',F6.4) - WRITE (KW,6820) SRTVIS, SRRVIS, SRAVIS, SRTNIR, SRRNIR, & - SRANIR - 6820 FORMAT (' In Atmosphere: ',' (VIS=0.53*S0)',2X, & - &'(NIR=0.47*S0)',1X,' SRTVIS=',F7.5,' SRRVIS=', & - F7.5,' SRAVIS=',F6.4,2X,' SRTNIR=',F7.5, & - &' SRRNIR=',F7.5,' SRANIR=',F6.4) - DO I = 1, 1 - IF ( KORDER==1 ) WRITE (KW,6821) - 6821 FORMAT (' ') - ENDDO -! - WRITE (KW,6840) - - 6840 FORMAT ( & - &' (8B) SPECTRAL/k-DISTRIBUTION COMPONENT BREAKDOWN'& - ,' FOR NET DOWNWARD SOLAR FLUX HEATING RATE',T106,& - &'SKNFLB(L,K) SKFHRL(L,K) SRKGAX(L,I)'/) - DO K = 1, 16 - ISR1(K) = NORDER(K) - IF ( KORDER==1 ) ISR1(K) = K - ENDDO - WRITE (KW,6841) (ISR1(K),K=1,16) - 6841 FORMAT (' K=',I5,2I8,2I7,I8,I9,7I8,I7,I8, & - &' Total') - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = DKS0(NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = DKS0(K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6842) (FSR1(K),K=1,17) - 6842 FORMAT (' DKS0=',F6.3,2F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3, & - F8.3,F11.3) - IF ( KORDER==0 ) WRITE (KW,6843) - 6843 FORMAT (' GAS= O3,O2 O3,NO2 O2 O2 O2', & - &' H2O',22X, & - &'H2O H2O H2O H2O CO2',5X, & - &'CO2 CO2 CO3,H2O,O2'/ & - &' SKNFLB (Spectral Net Flux)') - IF ( KORDER==1 ) WRITE (KW,6844) - 6844 FORMAT (' GAS= H2O H2O H2O H2O H2O', & - &' O2 O2 O2 CO2 CO2 CO2'& - ,18X,'O3,NO2 O3,O2 CO2,H2O,O2'/ & - &' SKDFLB (Spectral Net Flux)',T110,6('-'),'VIS', & - &5('-')) - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6845) (ISR1(K),K=1,16) - 6845 FORMAT (' N L=',I4,I9,I8,2I7,I8,I9,7I8,I7,I8, & - &' Total') - DO L = NL + 1, L1, -1 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SKNFLB(L,NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SKNFLB(L,K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6846) L, (FSR1(K),K=1,17) - 6846 FORMAT (I3,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3,F8.3,& - F11.3) - ENDDO - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6847) (ISR1(K),K=1,16) - 6847 FORMAT (/' SKFHRL (Spectral Heating Rate)'/' N L=',I4, & - I9,I8,2I7,I8,I9,7I8,I7,I8,' Total') - DO L = NL, L1, -1 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SKFHRL(L,NORDER(K)) - IF ( KORDER==1 ) FSR1(K) = SKFHRL(L,K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6848) L, (FSR1(K),K=1,17) - 6848 FORMAT (I3,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3,F8.3,& - F11.3) - ENDDO - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6849) (ISR1(K),K=1,16) - 6849 FORMAT (/ & - &' SRKGAX (Direct Beam Spectral Absorption at Ground)'& - /' N L=',I4,8I8,I9,4I8,I7,I8,' Total') - DO N = 1, 4 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SRKGAX(NORDER(K),N) - IF ( KORDER==1 ) FSR1(K) = SRKGAX(K,N) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6850) 0, (FSR1(K),K=1,17) - 6850 FORMAT (I2,1X,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3, & - F8.3,F11.3) - ENDDO - DO K = 1, 16 - ISR1(K) = K - IF ( KORDER==1 ) ISR1(K) = IORDER(K) - ENDDO - WRITE (KW,6851) - 6851 FORMAT (' SRKGAD (Diffuse Spectral Absorption at Ground)'& - ) - DO N = 1, 4 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SRKGAD(NORDER(K),N) - IF ( KORDER==1 ) FSR1(K) = SRKGAD(K,N) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6852) N, (FSR1(K),K=1,17) - 6852 FORMAT (I2,1X,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3, & - F8.3,F11.3) - ENDDO - WRITE (KW,6853) - 6853 FORMAT (' SRKGAD (Total Spectral Absorption at Ground)') - DO N = 1, 4 - SUMK = 0.0 - DO K = 1, 16 - FSR1(K) = SRKGAX(NORDER(K),N) - FSR2(K) = SRKGAD(NORDER(K),N) - IF ( KORDER==1 ) FSR1(K) = SRKGAX(K,N) - IF ( KORDER==1 ) FSR2(K) = SRKGAD(K,N) - FSR1(K) = FSR1(K) + FSR2(K) - SUMK = SUMK + FSR1(K) - ENDDO - FSR1(17) = SUMK - WRITE (KW,6854) N, (FSR1(K),K=1,17) - 6854 FORMAT (I2,1X,2F9.3,F8.3,2F7.3,F8.3,F9.3,7F8.3,F7.3, & - F8.3,F11.3) - ENDDO - WRITE (KW,6855) SRNFLB(L1), POCEAN, FSRNFG(1), PEARTH, & - FSRNFG(2), POICE, FSRNFG(3), PLICE, & - FSRNFG(4) - 6855 FORMAT (/' Absorption at Ground by Surface-type',T39, & - &'SRNFLB(1) = POCEAN * FSRNFG(1) + PEARTH * FSRNFG(2) '& - ,'+ POICE * FSRNFG(3) + PLICE * FSRNFG(4) '/T39, & - F7.3,' = ',F6.4,' *',F8.3,' + ',F6.4,' *',F8.3, & - &' + ',F6.4,' *',F8.3,' + ',F6.4,' *',F8.3) - CYCLE - ELSEIF ( INDX==9 ) THEN -!------------- -!------------- -! -! SIGMA=5.6697D-08 - TGMEAN = POCEAN*TGO**4 + PEARTH*TGE**4 + PLICE*TGLI**4 + & - POICE*TGOI**4 - TGMEAN = SQRT(TGMEAN) - TGMEAN = SQRT(TGMEAN) - SIGT4 = SIGMA*TGMEAN**4 - ITG = TGMEAN - WTG = TGMEAN - ITG - DO K = 1, 33 - BGFLUX(K) = PLANCK(ITG,K) & - - (PLANCK(ITG,K)-PLANCK(ITG+1,K))*WTG - BGFRAC(K) = BGFLUX(K)/SIGT4 - ENDDO - DO NW = 1, 5 - DO K = 1, 33 - DO L = L1, NL + 1 - IF ( NW==1 ) WFLB(L,K) = DFLB(L,K) - IF ( NW==2 ) WFLB(L,K) = UFLB(L,K) - IF ( NW==3 ) WFLB(L,K) = UFLB(L,K) - DFLB(L,K) - IF ( NW<=3 .OR. L<=NL ) THEN - IF ( NW==4 ) WFLB(L,K) = WFLB(L+1,K) & - - WFLB(L,K) - IF ( NW==5 .AND. ABS(TRFCRL(L))<1.E-10 ) & - WFLB(L,K) = 1.E-30 - IF ( NW==5 ) WFLB(L,K) = WFLB(L,K) & - /(ABS(TRFCRL(L))+1.E-10) - ENDIF - ENDDO - IF ( NW==1 ) WFSL(K) = DFSL(K) - IF ( NW==2 ) WFSL(K) = UFSL(K) - IF ( NW==3 ) WFSL(K) = UFSL(K) - DFSL(K) - IF ( NW==4 ) WFSL(K) = WFSL(K) - UFLB(L1,K) & - + DFLB(L1,K) -!sl IF(NW==5.and.ABS(TRSLCR) < 1.E-10) WFSL(K)=1.E-30 - IF ( NW==5 ) WFSL(K) = 0. - !nu =WFSL(K)/(ABS(TRSLCR)+1.E-10) - ENDDO - DO L = L1, NL + 1 - IF ( L<=NL .OR. NW<=3 ) THEN - ASUM1 = 0. - BSUM1 = 0. - CSUM1 = 0. - DSUM1 = 0. - ESUM1 = 0. - FSUM1 = 0. - SUMF = 0. - DO K = 2, 13 - ASUM1 = ASUM1 + WFSL(K) - BSUM1 = BSUM1 + BGFEMT(K) - CSUM1 = CSUM1 + BGFLUX(K) - DSUM1 = DSUM1 + BGFRAC(K) - ESUM1 = ESUM1 + TRCTCA(K) - FSUM1 = FSUM1 + TRGALB(K) - SUMF = SUMF + WFLB(L,K) - ENDDO - SUM1(L) = SUMF - ASUM2 = 0. - BSUM2 = 0. - CSUM2 = 0. - DSUM2 = 0. - ESUM2 = 0. - FSUM2 = 0. - SUMF = 0. - DO K = 14, 25 - ASUM2 = ASUM2 + WFSL(K) - BSUM2 = BSUM2 + BGFEMT(K) - CSUM2 = CSUM2 + BGFLUX(K) - DSUM2 = DSUM2 + BGFRAC(K) - ESUM2 = ESUM2 + TRCTCA(K) - FSUM2 = FSUM2 + TRGALB(K) - SUMF = SUMF + WFLB(L,K) - ENDDO - SUM2(L) = SUMF - ASUM3 = 0. - BSUM3 = 0. - CSUM3 = 0. - DSUM3 = 0. - ESUM3 = 0. - FSUM3 = 0. - SUMF = 0. - DO K = 26, 33 - ASUM3 = ASUM3 + WFSL(K) - BSUM3 = BSUM3 + BGFEMT(K) - CSUM3 = CSUM3 + BGFLUX(K) - DSUM3 = DSUM3 + BGFRAC(K) - ESUM3 = ESUM3 + TRCTCA(K) - FSUM3 = FSUM3 + TRGALB(K) - SUMF = SUMF + WFLB(L,K) - ENDDO - SUM3(L) = SUMF - ENDIF - ENDDO -! - NPAGE = 1 - WRITE (KW,6901) NW, FTYPE(NW) -! - 6901 FORMAT (' (9.',I1, & - &') THERMAL RADIATION: K-DISTRIBUTION', & - &' BREAKDOWN FOR ',1A8,' FLUX'//T21, & - &'PRINCIPAL REGION SUM',2X,'WINDOW',T52, & - &'WATER VAPOR:',T76, & - 'PRINCIPAL ABSORBER REGION'/20X,20('-'),2X, & - &6('-'),3X,81('-')) - WRITE (KW,6902) (K,K=1,13) - 6902 FORMAT (1X, & - &'LN PL TOTAL H2O CO2 O3 K='& - ,I2,4X,'K=',I2,12I7) - DO L = NL + 1, L1, -1 - IF ( L<=NL .OR. NW<=3 ) THEN - SUML = SUM1(L) + SUM2(L) + SUM3(L) + WFLB(L,1) - WRITE (KW,6903) L, PL(L), SUML, SUM1(L), SUM2(L)& - , SUM3(L), (WFLB(L,K),K=1,13) - 6903 FORMAT (1X,I2,2F8.2,3F7.2,F8.3,1X,12F7.3) - ENDIF - ENDDO - SUMA = ASUM1 + ASUM2 + ASUM3 + WFSL(1) - SUMB = BSUM1 + BSUM2 + BSUM3 + BGFEMT(1) - SUMC = CSUM1 + CSUM2 + CSUM3 + BGFLUX(1) - SUMD = DSUM1 + DSUM2 + DSUM3 + BGFRAC(1) - SUME = ESUM1 + ESUM2 + ESUM3 + TRCTCA(1) - SUMF = FSUM1 + FSUM2 + FSUM3 + TRGALB(1) - WRITE (KW,6904) SUMA, ASUM1, ASUM2, ASUM3, & - (WFSL(K),K=1,13) - 6904 FORMAT (/' SL',9X,4F7.2,F8.3,1X,12F7.3) - WRITE (KW,6905) SUMB, BSUM1, BSUM2, BSUM3, & - (BGFEMT(K),K=1,13) - 6905 FORMAT (/' BG',9X,4F7.2,F8.3,1X,12F7.3) - WRITE (KW,6906) SUMC, CSUM1, CSUM2, CSUM3, & - (BGFLUX(K),K=1,13) - 6906 FORMAT (' PF',9X,4F7.2,F8.3,1X,12F7.3) - WRITE (KW,6907) SUMD, DSUM1, DSUM2, DSUM3, & - (BGFRAC(K),K=1,13) - 6907 FORMAT (' FR',9X,4F7.2,F8.3,1X,12F7.3) - WRITE (KW,6908) SUME, ESUM1, ESUM2, ESUM3, & - (TRCTCA(K),K=1,13) - 6908 FORMAT (/' AC',9X,4F7.2,F8.3,1X,12F7.3) - WRITE (KW,6909) SUMF, FSUM1, FSUM2, FSUM3, & - (TRGALB(K),K=1,13) - 6909 FORMAT (' AG',9X,4F7.2,F8.3,1X,12F7.3) - NPAGE = 0 - WRITE (KW,6910) NPAGE - 6910 FORMAT (1I1/5X,'CARBON DIOXIDE:',T36, & - &'PRINCIPAL ABSORBER REGION',T85,'OZONE:',T101,& - &'PRINCIPAL ABSORBER REGION'/5X,76('-'),3X, & - &48('-')) - WRITE (KW,6911) (K,K=14,33) - 6911 FORMAT (1X,'LN K=',I2,6I7,5I6,4X,'K=',I2,1I7,6I6) - DO L = NL + 1, L1, -1 - IF ( L<=NL .OR. NW<=3 ) THEN - WRITE (KW,6912) L, (WFLB(L,K),K=14,33) - 6912 FORMAT (1X,I2,7F7.3,5F6.3,1X,2F7.3,6F6.3) - ENDIF - ENDDO - WRITE (KW,6913) (WFSL(K),K=14,33) - 6913 FORMAT (/' SL',7F7.3,5F6.3,1X,2F7.3,6F6.3) - WRITE (KW,6914) (BGFEMT(K),K=14,33) - 6914 FORMAT (/' BG',7F7.3,5F6.3,1X,2F7.3,6F6.3) - WRITE (KW,6915) (BGFLUX(K),K=14,33) - 6915 FORMAT (' PF',7F7.3,5F6.3,1X,2F7.3,6F6.3) - WRITE (KW,6916) (BGFRAC(K),K=14,33) - 6916 FORMAT (' FR',7F7.3,5F6.3,1X,2F7.3,6F6.3) - WRITE (KW,6917) (TRCTCA(K),K=14,33) - 6917 FORMAT (/' AC',7F7.3,5F6.3,1X,2F7.3,6F6.3) - WRITE (KW,6918) (TRGALB(K),K=14,33) - 6918 FORMAT (' AG',7F7.3,5F6.3,1X,2F7.3,6F6.3) - LINFIL = 2 - IF ( NW>3 ) LINFIL = 4 - DO I = 1, LINFIL - WRITE (KW,6919) - 6919 FORMAT (' ') - ENDDO - ENDDO - RETURN - ELSEIF ( INDX==10 ) THEN - CYCLE - ENDIF - ENDIF -! -!------------- -!------------- - IF ( AM_I_ROOT() ) THEN - WRITE (KW,6000) - 6000 FORMAT (' CALL WRITER(KW,0) :',2X,'PAGE 1/2 ', & - &'CONTROL PARAMS DEFINITIONS'// & - &' CONTROL PARAMTER DEFAULT PARAMETER DESCRIPTION'& - ) - - WRITE (KW,6001) KUVFAC, KSNORM, KWTRAB, KGGVDF, KPGRAD, & - KLATZ0, KCLDEM, KANORM, KFPCO2, KPFOZO, & - KSIALB, KORDER, KUFH2O, KUFCO2, KCSELF, & - KCFORN -!nu 2 ! /7X,' MEANAC = ',I1,' 0 Use Ann-Mean Aer Clim' -!nu 3 ! /7X,' MEANDD = ',I1,' 0 Use Ann-Mean Des Dust' -!nu 4 ! /7X,' MEANVA = ',I1,' 0 Use Ann-Mean Volc Aer' -!nu 5 /7X,' NCARO3 = ',I1,' 0 NCAR London 1976 Ozon'/ - 6001 FORMAT (7X,' KUVFAC = ',I1, & - &' 0 ON/OFF UV Mult Factor'/7X, & - &' KSNORM = ',I1, & - &' 0 Norm S0 when KUVFAC=1'/7X, & - &' KWTRAB = ',I1, & - &' 0 WRITER: Qab,Qex,Qsc,g'/7X, & - &' KGGVDF = ',I1, & - &' 0 Use GHG VertProf Grad'/7X, & - &' KPGRAD = ',I1, & - &' 1 Pole-to-Pole GHG Grad'/7X, & - &' KLATZ0 = ',I1, & - &' 1 Use GHG VDist Lat Dep'/7X, & - &' KCLDEM = ',I1, & - &' 1 Use TopCloud Scat Cor'/7X, & - &' KANORM = ',I1, & - &' 0 Use SGP Atmo Col Norm'/7X, & - &' KFPCO2 = ',I1, & - &' 0 1=MOD CO2PROF: FPXCO2'/7X, & - &' KPFOZO = ',I1, & - &' 0 1=MOD O3 PROF: FPXOZO'/7X, & - &' KSIALB = ',I1, & - &' 0 Schramm"s ocn ice alb'/7X, & - &' KORDER = ',I1, & - &' 0 WRITER k-d spec order'/7X, & - &' KUFH2O = ',I1, & - &' 1 Col Absorber Scal H2O'/7X, & - &' KUFCO2 = ',I1, & - &' 1 Col Absorber Scal CO2'/7X, & - &' KCSELF = ',I1, & - &' 1 H2O Cont Self-Broaden'/7X, & - &' KCFORN = ',I1, & - &' 1 H2O Con Foreign-Broad') - ! 7X,' KVRAER = ',I1,' 1 Repartition Aer VDist' -! - WRITE (KW,6004) - 6004 FORMAT (/ & - &' CONTROL PARAMTER DEFAULT SNOW/ICE FACTORS'& - ) - - WRITE (KW,6005) agexpf, albdif - 6005 FORMAT (7X,' AGEXPF = ',F7.3, & - &' SNOWAGE XPFACTOR SH EARTH'/7X,' SH O = ',& - F7.3,' " " " OCICE'/7X, & - &' SH L = ',F7.3, & - &' " " " LDICE'/7X,' NH E = ',& - F7.3,' " " NH EARTH'/7X, & - &' NH O = ',F7.3, & - &' " " " OCICE'/7X,' NH L = ',& - F7.3,' " " " LDICE'/7X, & - &' ALBDIF = ',F7.3, & - &' SNOW/ICE ALBDIF SH EARTH'/7X,' SH O = ',& - F7.3,' " " " OCICE'/7X, & - &' SH L = ',F7.3, & - &' " " " LDICE'/7X,' NH E = ',& - F7.3,' " " NH EARTH'/7X, & - &' NH O = ',F7.3, & - &' " " " OCICE'/7X,' NH L = ',& - F7.3,' " " " LDICE') -! - WRITE (KW,6006) - 6006 FORMAT ('0CONTROL PARAMTER VALUE',16X,' DEFAULT') - WRITE (KW,6007) REFF0, VEFF0, AVSCAT, ANSCAT, AVFOAM, ANFOAM - 6007 FORMAT (7X,' REFF0 = ',F7.3, & - &' 0.300 '/7X,' VEFF0 = ',& - F7.3,' 0.350 '/7X, & - &' AVSCAT = ',F7.5, & - &' 0.01560 '/7X,' ANSCAT = ',& - F7.5,' 0.00020 '/7X, & - &' AVFOAM = ',F7.5, & - &' 0.21970 '/7X,' ANFOAM = ',& - F7.5,' 0.15140 ') - WRITE (KW,6008) - 6008 FORMAT (/10X,'UV Solar Flux Spectral Partitions and Factors'& - ) - WRITE (KW,6009) UVWAVL, UVFACT - 6009 FORMAT (10X,'UVWAVL = ',F7.5,2F8.5/10X,'UVFACT = ',F7.5, & - 2F8.5) -! -!nu WRITE(KW,6013) - 6013 FORMAT (/ & - &' CONTROL PARAMETER PI0VIS PI0TRA DEFAULT'& - ) -!nu WRITE(KW,6014) PI0VIS,PI0TRA - 6014 FORMAT (7X,' ACID1 = ',F8.6,F11.6, & - &' 1.0 '/7X,' SSALT = ',F8.6, & - F11.6,' 1.0 '/7X,' SLFT1 = ', & - F8.6,F11.6,' 1.0 '/7X, & - &' SLFT2 = ',F8.6,F11.6, & - ' 1.0 '/7X,' BSLT1 = ',F8.6, & - F11.6,' .98929 '/7X,' BSLT2 = ', & - F8.6,F11.6,' .95609 '/7X, & - &' DUST1 = ',F8.6,F11.6, & - ' .91995 '/7X,' DUST2 = ',F8.6, & - F11.6,' .78495 '/7X,' DUST3 = ', & - F8.6,F11.6,' .63576 '/7X, & - &' CARB1 = ',F8.6,F11.6, & - ' .31482 '/7X,' CARB2 = ',F8.6, & - F11.6,' .47513 ') - - WRITE (KW,6019) - 6019 FORMAT (/' GHGAS',9X,'PPMVK0 PPMVDF PPGRAD') - WRITE (KW,6020) (GHG(I),PPMVK0(I),PPMVDF(I),PPGRAD(I),I=1, & - 12) - 6020 FORMAT (1X,a6,' ',F15.7,F10.5,F10.5) - ENDIF -!------------- -!------------- -! - ENDDO - 6308 FORMAT (' TKeff= ',F6.2,2F7.2,' SRKALB=',16F6.4/1X, & - &'At Top of Atm: ',' BTEMPW=',F6.2,1X,' TRUFTW=',F6.3,2X, & - &' SRIVIS=',F6.2,' SROVIS=',F6.2,' PLAVIS=',F6.4,2X, & - &' SRINIR=',F6.2,' SRONIR=',F6.2,' PLANIR=',F6.4) - 6423 FORMAT (T81,'FGOLDH(',I1,') =',1P,E9.2,5X,0P,F7.4) - 6425 FORMAT (' ') - 6438 FORMAT (/T81,'SUM COLUMN TAU(0.55) =',F10.4) - 6442 FORMAT (I3,6X,15F8.5) - 6452 FORMAT (I3,6X,15F8.5) - 6462 FORMAT (I3,6X,15F8.5) - 6472 FORMAT (I3,6X,15F8.5) - END SUBROUTINE WRITER - - SUBROUTINE WRITET(KWRU,INDEX,JYRREF,JYRNOW,JMONTH,KLIMIT) - USE AERPARAM_MOD, ONLY:UPDATEAEROSOL, UPDATEAEROSOL2 - USE DUSTPARAM_MOD, ONLY:UPDDST2 - USE O3MOD, ONLY:UPDO3D, UPDO3D_SOLAR, plbo3, nlo3 -#ifdef HIGH_FREQUENCY_O3_INPUT - USE O3MOD, ONLY:UPDO3D_HIGHFREQUENCY -#endif - IMPLICIT NONE -! -! -! ------------------------------------------------------------------ -! WRITET GHG, Solar UV, Ozone, Aerosol Trend Diagnostic Information -! -! INDEX -! 1 GHG DT0 Trends / FULGAS Ratios for CO2,NO2,CH4,F11,F12 -! 2 GHG DF Change / Ann Increase Rate CO2,NO2,CH4,F11,F12 -! 3 Lean Solar Constant, UV Spectral Variation Time Trends -! 4 Ozone Zonal-mean (Latitude and Vertical) Distributions -! 5 Ozone Surface-150mb, 150mb-TOA, Column Longitude Distr -! A O3 (Wang-Jacobs) Relative Longitudinal Distribution -! B O3 (London-NCAR) Relative Longitudinal Distribution -! C O3 (W-J, London) Relative Longitudinal Distribution -! 6 Tropospheric Climatology Aerosol Latitude/Height Distr -! A Zonal-mean Extinction Optical Depth -! B Zonal-mean Single Scattering Albedo -! C Zonal-mean Asymmetry Parameter -! 7 Tropospheric Desert Dust Aerosol Latitude/Height Distr -! A Zonal-mean Extinction Optical Depth -! B Zonal-mean Single Scattering Albedo -! C Zonal-mean Asymmetry Parameter -! 8 Stratospheric (Volcanic) Aerosol Latitude/Height Distr -! A Zonal-mean Extinction Optical Depth -! B Zonal-mean Single Scattering Albedo -! C Zonal-mean Asymmetry Parameter -! 9 Total Column Atmospheric Aerosol Latitude/Height Distr -! A Zonal-mean Extinction Optical Depth -! B Zonal-mean Single Scattering Albedo -! C Zonal-mean Asymmetry Parameter -! NOTE: -! Time Trend (year) Specification is by JYRREF to JYRNOW -! Time Specification (O3,Aerosol) is by JYRREF to JMONTH -! (If JMONTH = 0, JDAY is used) -! -! INDEX < 10 is selective, INDEX > 10 is digit inclusive -! KLIMIT = 0 full output, KLIMIT > 0 abbreviated output -! KWRU directs the output to selected (KWRU) file number -! ------------------------------------------------------------------ -! - INTEGER, INTENT(IN) :: KWRU, INDEX, JYRREF, JYRNOW, JMONTH, & - KLIMIT - - REAL*8 WREF(7), WDAT(7), WPPM(7), XRAT(5) - REAL*8, DIMENSION(49,LX) :: QX, QS, QG, QP, O3 - REAL*8, DIMENSION(49) :: QXCOL, QSCOL, QGCOL, QPCOL, O3COL - REAL*8 SFL0(5), SFLX(5), DFLX(5), RFLX(5), O3L(46,72) - INTEGER :: LO3(36) -! - INTEGER, PARAMETER :: NSW1 = 24, NSW2 = 32, NSW3 = 40, NSW4 = 48 -! - CHARACTER*32, PARAMETER :: CHAER(4) = (/ & - &'Tropospheric Climatology Aerosol', & - &'Tropospheric Desert Dust Aerosol', & - &'Stratospheric (Volcanic) Aerosol', & - &'Total Column Atmospheric Aerosol'/) - - REAL*8 YREF11, ZREF12, SUMO3, QOSH, QONH, QOGL, SUMXL, SUMGL, & - SUMSL, QXSH, QXNH, QXGL, QSSH, QSNH, QSGL, QPSH, QPNH, & - QPGL, QGSH, QGNH, QGGL - INTEGER KW, INDJ, INDI, INDX, KINDEX, I, JJDAYG, JYEARG, KWSKIP, & - J, IYEAR, NSPACE, LMO, K, mavg, iyr1, lmax, icyc, JYEARS, & - M, JJDAYO, L, JJ, N, N1, N2, II, KAEROS, LL1, KA, JJDAY, & - icycf -! - KW = KWRU - INDJ = MOD(INDEX,10) - IF ( INDJ<1 ) INDJ = 10 - INDI = 1 - IF ( INDEX==0 ) INDJ = 1 - IF ( INDEX<11 ) INDI = INDJ - DO INDX = INDI, INDJ -! - IF ( INDX==3 ) THEN -! -!------------- -!------------- -! - IF ( ksolar>=0 ) THEN - LMO = (1950-IY1S0)*12 + 1 - IF ( ksolar>1 ) LMO = NINT(1950-yr1s0+1.5) - DO I = 1, 5 - SFL0(I) = 0.D0 - ENDDO - DO K = 1, 190 - IF ( K<=NSW1 ) SFL0(1) = SFL0(1) + UV_SSI(LMO,K) & - *DS_SSI(K) - IF ( K>NSW1 .AND. K<=NSW2 ) SFL0(2) = SFL0(2) & - + UV_SSI(LMO,K)*DS_SSI(K) - IF ( K>NSW2 .AND. K<=NSW3 ) SFL0(3) = SFL0(3) & - + UV_SSI(LMO,K)*DS_SSI(K) - IF ( K>NSW3 .AND. K<=NSW4 ) SFL0(4) = SFL0(4) & - + UV_SSI(LMO,K)*DS_SSI(K) - SFL0(5) = SFL0(5) + UV_SSI(LMO,K)*DS_SSI(K) - ENDDO -! - IF ( ksolar==2 .OR. ksolar==9 ) WRITE (KW,6299) & - INT(yr1s0), INT(yr2s0), JYRREF, JYRNOW, SFL0(5) - 6299 FORMAT (/ & - &' (3)=INDEX Annual-mean Solar flux (from ann. SSI input'& - ,I6,'-',I4,' data) for JYRREF=',I4,' to JYRNOW=',I4, & - &' mid',' 1950 Ref S00WM2=',F9.4/12X, & - &'Solar UV Spectral Flux W/m2',T57, & - &'Delta Solar UV Spectral Flux W/m2',T97, & - &'Solar UV Spectral Flux Ratios'/ & - &' YEAR 0-280 280-320 320-360 360-400 Total ',6X, & - &'0-280 280-320 320-360 360-400 Total ',4X, & - &'0-280 280-320 320-360 360-400 Total ') - IF ( ksolar<2 ) WRITE (KW,6300) JYRREF, JYRNOW, SFL0(5) - 6300 FORMAT (/ & - &' (3)=INDEX Annual-mean Solar flux (from J.Lean monthly'& - ,' 1882-1998 data) for JYRREF=',I4,' to JYRNOW=',I4, & - &' Jan',' 1950 Ref S00WM2=',F9.4/12X, & - &'Solar UV Spectral Flux W/m2',T57, & - &'Delta Solar UV Spectral Flux W/m2',T97, & - &'Solar UV Spectral Flux Ratios'/ & - &' YEAR 0-280 280-320 320-360 360-400 Total ',6X, & - &'0-280 280-320 320-360 360-400 Total ',4X, & - &'0-280 280-320 320-360 360-400 Total ') -! - IF ( ksolar<2 ) THEN - mavg = 12 - iyr1 = IY1S0 - lmax = MS0X - ELSE - mavg = 1 - iyr1 = yr1s0 - lmax = NINT(yr2s0-yr1s0+1) - ENDIF - icyc = mavg*ICYCS0 - icycf = mavg*ICYCS0F - DO J = JYRREF, JYRNOW - IF ( j>2000 ) icyc = icycf - KWSKIP = 0 - IF ( J>JYRREF ) KWSKIP = KLIMIT - IF ( J==JYRNOW ) KWSKIP = 0 - JYEARS = J - DO I = 1, 5 - SFLX(I) = 0.D0 - ENDDO - LMO = (JYEARS-iyr1)*mavg - DO M = 1, mavg - LMO = LMO + 1 - IF ( LMO>lmax ) LMO = LMO - & - icyc*((LMO-lmax+icyc-1)/icyc) - IF ( LMO<1 ) LMO = LMO + icyc*((icyc-LMO)/icyc) - DO K = 1, 190 - IF ( K<=NSW1 ) SFLX(1) = SFLX(1) + UV_SSI(LMO,K)& - *DS_SSI(K) - IF ( K>NSW1 .AND. K<=NSW2 ) SFLX(2) = SFLX(2) & - + UV_SSI(LMO,K)*DS_SSI(K) - IF ( K>NSW2 .AND. K<=NSW3 ) SFLX(3) = SFLX(3) & - + UV_SSI(LMO,K)*DS_SSI(K) - IF ( K>NSW3 .AND. K<=NSW4 ) SFLX(4) = SFLX(4) & - + UV_SSI(LMO,K)*DS_SSI(K) - SFLX(5) = SFLX(5) + UV_SSI(LMO,K)*DS_SSI(K) - ENDDO - ENDDO - DO I = 1, 5 - SFLX(I) = SFLX(I)/mavg - DFLX(I) = SFLX(I) - SFL0(I) - RFLX(I) = SFLX(I)/SFL0(I) - ENDDO - IF ( KWSKIP==0 ) WRITE (KW,6301) JYEARS, & - (SFLX(I),I=1,5), (DFLX(I),I=1,5), (RFLX(I),I=1,5) - 6301 FORMAT (2X,I4,1X,4F8.4,F10.4,2X,5F8.4,2X,5F8.5) - NSPACE = JYEARS - (JYEARS/10)*10 - IF ( KLIMIT<=0 ) THEN - IF ( NSPACE==0 ) WRITE (KW,6302) - 6302 FORMAT (' ') - ENDIF - ENDDO - ENDIF - ELSEIF ( INDX==4 ) THEN -! -!------------- -!------------- -! - JJDAYO = JMONTH*30 - 15 - IF ( JMONTH<1 ) JJDAYO = JDAY - CALL UPDO3D(JYRREF,JJDAYO,O3JDAY,O3JREF) -#ifdef HIGH_FREQUENCY_O3_INPUT - CALL UPDO3D_HIGHFREQUENCY(JYRREF,JJDAYO, & - O3JDAY_HF_modelLevels) -#endif - CALL UPDO3D_SOLAR(JJDAYO,S00WM2*RATLS0,O3JDAY) - DO J = 1, 46 - DO L = 1, NL - O3(J,L) = 0.D0 - ENDDO - JLAT = J - DO I = 1, 72 - ILON = I -!!! CALL GETO3D(ILON,JLAT) - CALL REPART(O3JDAY(1,IGCM,JGCM),PLBO3,NLO3+1, & - U0GAS(1,3),PLB0,NL+1) - DO L = 1, NL - O3(J,L) = O3(J,L) + U0GAS(L,3)/72.D0 - ENDDO - ENDDO - SUMO3 = 0.D0 - DO L = 1, NL - SUMO3 = SUMO3 + O3(J,L) - ENDDO - O3COL(J) = SUMO3 - ENDDO - CALL BOXAV1(DLAT46,O3COL,46,1,23,QOSH) - CALL BOXAV1(DLAT46,O3COL,46,24,46,QONH) - CALL BOXAV1(DLAT46,O3COL,46,1,46,QOGL) - O3COL(47) = QOSH - O3COL(48) = QONH - O3COL(49) = QOGL - DO L = 1, NL - CALL BOXAV1(DLAT46,O3(1,L),46,1,23,QOSH) - CALL BOXAV1(DLAT46,O3(1,L),46,24,46,QONH) - CALL BOXAV1(DLAT46,O3(1,L),46,1,46,QOGL) - O3(47,L) = QOSH - O3(48,L) = QONH - O3(49,L) = QOGL - ENDDO -! - IF ( KLIMIT>0 ) WRITE (KW,6400) JYRREF, JJDAYO, JMONTH, & - MADO3M, (L,L=2,NL) - 6400 FORMAT (/' (4)=INDEX JYRREF=',I5,' JDAY=',I3,' JMONTH=',& - I2,T50, & - &' Ozone: Zonal-mean Vertical Distribution (cmSTP)', & - T126,'MADO3=',I2/' JLAT DLAT46 COLUMN L = 1', & - 14I7/I31,14I7) - IF ( KLIMIT<1 ) WRITE (KW,7400) JYRREF, JJDAYO, JMONTH, & - MADO3M, (PLB0(I),I=1,15), (L,L=2,15) - 7400 FORMAT (/' (4)=INDEX JYRREF=',I5,' JDAY=',I3,' JMONTH=',& - I2,T50, & - &' Ozone: Zonal-mean Vertical Distribution (cmSTP)', & - T126,'MADO3=',I2//21X,'PLB0 =',F6.1,9F7.1, & - &5F7.2/' JLAT DLAT46 COLUMN L = 1',14I7) - IF ( KLIMIT<1 .AND. nl>15 ) THEN - WRITE (KW,'(F33.2,14F7.2)') (PLB0(I),I=16,NL) - WRITE (KW,'(I31,14I7)') (L,L=16,NL) - ENDIF -! - DO JJ = 1, 46 - J = 47 - JJ - IF ( KLIMIT<=0 ) THEN - WRITE (KW,6401) J, DLAT46(J), O3COL(J), & - (O3(J,L),L=1,NL) - 6401 FORMAT (I5,F8.2,F9.5,4X,15(1x,F6.5)/26X,15(1x,F6.5)) - ENDIF - ENDDO - IF ( KLIMIT<1 ) WRITE (KW,6402) - WRITE (KW,6403) O3COL(48), (O3(48,L),L=1,NL) - 6403 FORMAT (11X,'NH',F9.5,4X,15(1x,F6.5)/26X,15(1x,F6.5)) - IF ( KLIMIT<1 ) WRITE (KW,6402) - WRITE (KW,6404) O3COL(47), (O3(47,L),L=1,NL) - 6404 FORMAT (11X,'SH',F9.5,4X,15(1x,F6.5)/26X,15(1x,F6.5)) - IF ( KLIMIT<1 ) WRITE (KW,6402) - WRITE (KW,6405) O3COL(49), (O3(49,L),L=1,NL) - 6405 FORMAT (7X,'GLOBAL',F9.5,4X,15(1x,F6.5)/26X,15(1x,F6.5)) - ELSEIF ( INDX==5 ) THEN -! -! -!------------- -!------------- -! - JJDAYO = JMONTH*30 - 15 - IF ( JMONTH<1 ) JJDAYO = JDAY - CALL UPDO3D(JYRREF,JJDAYO,O3JDAY,O3JREF) -#ifdef HIGH_FREQUENCY_O3_INPUT - CALL UPDO3D_HIGHFREQUENCY(JYRREF,JJDAYO, & - O3JDAY_HF_modelLevels) -#endif - CALL UPDO3D_SOLAR(JJDAYO,S00WM2*RATLS0,O3JDAY) - DO N = 1, 3 - N1 = 1 - N2 = 8 - IF ( N==2 ) N1 = 9 - IF ( N>1 ) N2 = NL - DO J = 1, 46 - JLAT = J - DO I = 1, 72 - ILON = I -!!! CALL GETO3D(ILON,JLAT) - CALL REPART(O3JDAY(1,IGCM,JGCM),PLBO3,NLO3+1, & - U0GAS(1,3),PLB0,NL+1) - SUMO3 = 0.D0 - DO L = N1, N2 - SUMO3 = SUMO3 + U0GAS(L,3) - ENDDO - O3L(J,I) = SUMO3 - ENDDO - ENDDO - DO J = 1, 46 - SUMO3 = 0.D0 - DO I = 1, 72 - SUMO3 = SUMO3 + O3L(J,I)/72.D0 - ENDDO - DO I = 1, 72 - O3L(J,I) = O3L(J,I)/SUMO3 - ENDDO - ENDDO -! - IF ( N==1 ) WRITE (KW,6510) JYRREF, JJDAYO, JMONTH, & - MADO3M, (I,I=10,310,10) - 6510 FORMAT (/' 5A=INDEX JYEAR=',I5,' JDAY=',I3, & - &' JMONTH=',I2,T50, & - &' Ozone Longitudinal Variation: Troposphere', & - &' (Wang-Jacobs) Surf to 150 mb',T126,'MADO3=', & - &I2/' J LON=0',31I4) - IF ( N==2 ) WRITE (KW,6520) JYRREF, JJDAYO, JMONTH, & - MADO3M, (I,I=10,310,10) - 6520 FORMAT (/' 5B=INDEX JYEAR=',I5,' JDAY=',I3, & - &' JMONTH=',I2,T50, & - &' Ozone Longitudinal Variation: Stratosphere', & - &' (London-NCAR) 150 mb to TOA',T126,'MADO3=', & - &I2/' J LON=0',31I4) - IF ( N==3 .AND. KLIMIT<1 ) WRITE (KW,6530) JYRREF, & - JJDAYO, JMONTH, MADO3M, (I,I=10,310,10) - 6530 FORMAT (/' 5C=INDEX JYEAR=',I5,' JDAY=',I3, & - &' JMONTH=',I2,T50, & - &' Ozone Longitudinal Variation: Total Column', & - &' (W-J/London) Surface to TOA',T126,'MADO3=', & - &I2/' J LON=0',31I4) - IF ( KLIMIT<1 ) WRITE (KW,6540) - 6540 FORMAT (' ') -! - IF ( N/=3 .OR. KLIMIT<=0 ) THEN - DO JJ = 1, 46 - J = 47 - JJ - KWSKIP = KLIMIT - IF ( J==36 ) KWSKIP = 0 - IF ( J==24 ) KWSKIP = 0 - IF ( J==12 ) KWSKIP = 0 - DO I = 1, 36 - II = I*2 - 1 - LO3(I) = O3L(J,II)*100.D0 + 0.5D0 - ENDDO - IF ( KWSKIP==0 ) WRITE (KW,6501) J, (LO3(I),I=1,32) - 6501 FORMAT (I4,1X,36I4) - ENDDO - ENDIF -! - ENDDO - ELSEIF ( INDX==6 .OR. INDX==7 .OR. INDX==8 .OR. INDX==9 ) THEN -! -!------------- -!------------- -! - KAEROS = 4 - IF ( INDX==6 ) KAEROS = 1 - IF ( INDX==7 ) KAEROS = 2 - IF ( INDX==8 ) KAEROS = 3 - LL1 = 1 - IF ( INDX==8 .AND. NL>15 ) LL1 = NL - 14 - JJDAY = JMONTH*30 - 15 - IF ( JMONTH<1 ) JJDAY = JDAY - K = 6 - IF ( MADAER==3 ) THEN - ! newer aerosol fields - IF ( KAEROS==1 .OR. KAEROS>3 ) & - CALL UPDATEAEROSOL2(JYRREF,JJDAY,a6jday,plbaer) - ELSE - IF ( KAEROS==1 .OR. KAEROS>3 ) & - CALL UPDATEAEROSOL(JYRREF,JJDAY,a6jday,plbaer) - ENDIF - IF ( KAEROS==2 .OR. KAEROS>3 ) CALL UPDDST2(JYRREF,JJDAY) - IF ( KAEROS==3 .OR. KAEROS>3 ) CALL UPDVOL(JYRREF,JJDAY) -! - DO J = 1, 46 - DO L = 1, NL - QX(J,L) = 0.D0 - QS(J,L) = 0.D0 - QG(J,L) = 0.D0 - ENDDO - JLAT = J - DO I = 1, 72 - ILON = I - IF ( KAEROS==1 .OR. KAEROS>3 ) CALL GETAER - IF ( KAEROS==2 .OR. KAEROS>3 ) CALL GETDST - IF ( KAEROS==3 .OR. KAEROS>3 ) CALL GETVOL - DO L = 1, NL - IF ( KAEROS==1 .OR. KAEROS>3 ) QX(J,L) = QX(J,L) & - + SRAEXT(L,K)/72.D0 - IF ( KAEROS==2 .OR. KAEROS>3 ) QX(J,L) = QX(J,L) & - + SRDEXT(L,K)/72.D0 - IF ( KAEROS==3 .OR. KAEROS>3 ) QX(J,L) = QX(J,L) & - + SRVEXT(L,K)/72.D0 - IF ( KAEROS==1 .OR. KAEROS>3 ) QS(J,L) = QS(J,L) & - + SRASCT(L,K)/72.D0 - IF ( KAEROS==2 .OR. KAEROS>3 ) QS(J,L) = QS(J,L) & - + SRDSCT(L,K)/72.D0 - IF ( KAEROS==3 .OR. KAEROS>3 ) QS(J,L) = QS(J,L) & - + SRVSCT(L,K)/72.D0 - IF ( KAEROS==1 .OR. KAEROS>3 ) QG(J,L) = QG(J,L) & - + SRAGCB(L,K)*SRASCT(L,K)/72.D0 - IF ( KAEROS==2 .OR. KAEROS>3 ) QG(J,L) = QG(J,L) & - + SRDGCB(L,K)*SRDSCT(L,K)/72.D0 - IF ( KAEROS==3 .OR. KAEROS>3 ) QG(J,L) = QG(J,L) & - + SRVGCB(L,K)*SRVSCT(L,K)/72.D0 - ENDDO - ENDDO - SUMXL = 1.D-10 - SUMSL = 1.D-20 - SUMGL = 1.D-20 - DO L = 1, NL - SUMXL = SUMXL + QX(J,L) - SUMSL = SUMSL + QS(J,L) - SUMGL = SUMGL + QG(J,L) - QG(J,L) = (1.D-20+QG(J,L))/(1.D-10+QS(J,L)) - QP(J,L) = (1.D-20+QS(J,L))/(1.D-10+QX(J,L)) - IF ( QP(J,L)>0.99999D0 ) QP(J,L) = 0.99999D0 - ENDDO - QXCOL(J) = SUMXL - QSCOL(J) = SUMSL - QGCOL(J) = (1.D-15+SUMGL)/(1.D-05+SUMSL) - QPCOL(J) = (1.D-20+SUMSL)/(1.D-10+SUMXL) - ENDDO - CALL BOXAV1(DLAT46,QXCOL,46,1,23,QXSH) - CALL BOXAV1(DLAT46,QXCOL,46,24,46,QXNH) - CALL BOXAV1(DLAT46,QXCOL,46,1,46,QXGL) - QXCOL(47) = QXSH - QXCOL(48) = QXNH - QXCOL(49) = QXGL - CALL BOXAV1(DLAT46,QSCOL,46,1,23,QSSH) - CALL BOXAV1(DLAT46,QSCOL,46,24,46,QSNH) - CALL BOXAV1(DLAT46,QSCOL,46,1,46,QSGL) - QSCOL(47) = QSSH - QSCOL(48) = QSNH - QSCOL(49) = QSGL - CALL BOXAV2(DLAT46,QXCOL,QPCOL,46,1,23,QPSH) - CALL BOXAV2(DLAT46,QXCOL,QPCOL,46,24,46,QPNH) - CALL BOXAV2(DLAT46,QXCOL,QPCOL,46,1,46,QPGL) - QPCOL(47) = QPSH - QPCOL(48) = QPNH - QPCOL(49) = QPGL - CALL BOXAV2(DLAT46,QSCOL,QGCOL,46,1,23,QGSH) - CALL BOXAV2(DLAT46,QSCOL,QGCOL,46,24,46,QGNH) - CALL BOXAV2(DLAT46,QSCOL,QGCOL,46,1,46,QGGL) - QGCOL(47) = QGSH - QGCOL(48) = QGNH - QGCOL(49) = QGGL - DO L = 1, NL - CALL BOXAV1(DLAT46,QX(1,L),46,1,23,QXSH) - CALL BOXAV1(DLAT46,QX(1,L),46,24,46,QXNH) - CALL BOXAV1(DLAT46,QX(1,L),46,1,46,QXGL) - QX(47,L) = QXSH - QX(48,L) = QXNH - QX(49,L) = QXGL - CALL BOXAV1(DLAT46,QS(1,L),46,1,23,QSSH) - CALL BOXAV1(DLAT46,QS(1,L),46,24,46,QSNH) - CALL BOXAV1(DLAT46,QS(1,L),46,1,46,QSGL) - QS(47,L) = QSSH - QS(48,L) = QSNH - QS(49,L) = QSGL - CALL BOXAV2(DLAT46,QX(1,L),QP(1,L),46,1,23,QPSH) - CALL BOXAV2(DLAT46,QX(1,L),QP(1,L),46,24,46,QPNH) - CALL BOXAV2(DLAT46,QX(1,L),QP(1,L),46,1,46,QPGL) - QP(47,L) = QPSH - QP(48,L) = QPNH - QP(49,L) = QPGL - CALL BOXAV2(DLAT46,QS(1,L),QG(1,L),46,1,23,QGSH) - CALL BOXAV2(DLAT46,QS(1,L),QG(1,L),46,24,46,QGNH) - CALL BOXAV2(DLAT46,QS(1,L),QG(1,L),46,1,46,QGGL) - QG(47,L) = QGSH - QG(48,L) = QGNH - QG(49,L) = QGGL - ENDDO -! - KA = KAEROS - IF ( KLIMIT>0 ) WRITE (KW,6600) INDX, JYRREF, JJDAY, JMONTH,& - CHAER(KA), (L,L=LL1,LL1+14) - 6600 FORMAT (/I3,'A=INDEX JYEAR=',I5,' JDAY=',I3,' JMONTH=', & - I2,T50,' ZONAL MEAN AEROSOL OPTICAL DEPTH',T100, & - &A32/' JLAT DLAT46 COLUMN L =',I4,14I7) - IF ( KLIMIT<1 ) WRITE (KW,7600) INDX, JYRREF, JJDAY, JMONTH,& - CHAER(KA), (PLB0(I),I=LL1,LL1+14), & - (L,L=LL1,LL1+14) - 7600 FORMAT (/I3,'A=INDEX JYEAR=',I5,' JDAY=',I3,' JMONTH=', & - I2,T50,' ZONAL MEAN AEROSOL OPTICAL DEPTH',T100, & - A32//21X,'PLB0 =',F6.1,9F7.1, & - &5F7.2/' JLAT DLAT46 COLUMN L =',I4,14I7) -! - IF ( KLIMIT<1 ) THEN - DO JJ = 1, 46 - J = 47 - JJ - WRITE (KW,6601) J, DLAT46(J), QXCOL(J), & - (QX(J,L),L=LL1,LL1+14) - 6601 FORMAT (I5,F8.2,F9.5,4X,15F7.5) - ENDDO - WRITE (KW,6602) QXCOL(48), (QX(48,L),L=LL1,LL1+14) - 6602 FORMAT (/11X,'NH',F9.5,4X,15F7.5) - WRITE (KW,6603) QXCOL(47), (QX(47,L),L=LL1,LL1+14) - 6603 FORMAT (/11X,'SH',F9.5,4X,15F7.5) - WRITE (KW,6604) QXCOL(49), (QX(49,L),L=LL1,LL1+14) - 6604 FORMAT (/7X,'GLOBAL',F9.5,4X,15F7.5) - ENDIF - IF ( KLIMIT>0 ) THEN - WRITE (KW,6605) QXCOL(48), (QX(48,L),L=LL1,LL1+14) - 6605 FORMAT (11X,'NH',F9.5,4X,15F7.5) - WRITE (KW,6606) QXCOL(47), (QX(47,L),L=LL1,LL1+14) - 6606 FORMAT (11X,'SH',F9.5,4X,15F7.5) - WRITE (KW,6607) QXCOL(49), (QX(49,L),L=LL1,LL1+14) - 6607 FORMAT (7X,'GLOBAL',F9.5,4X,15F7.5) - ENDIF -! - IF ( KLIMIT<=0 ) THEN - WRITE (KW,6610) INDX, JYRREF, JJDAY, JMONTH, CHAER(KA), & - (PLB0(I),I=LL1,LL1+14), (L,L=LL1,LL1+14) - 6610 FORMAT (/I3,'B=INDEX JYEAR=',I5,' JDAY=',I3, & - ' JMONTH=',I2,T50, & - &' ZONAL MEAN AEROSOL SINGLE SCATTERING ALBEDO', & - T100,A32//21X,'PLB0 =',F6.1,9F7.1, & - &5F7.2/' JLAT DLAT46 COLUMN L =',I4,14I7) -! - DO JJ = 1, 46 - J = 47 - JJ - WRITE (KW,6611) J, DLAT46(J), QPCOL(J), & - (QP(J,L),L=LL1,LL1+14) - 6611 FORMAT (I5,F8.2,F9.5,4X,15F7.5) - ENDDO - WRITE (KW,6612) QPCOL(48), (QP(48,L),L=LL1,LL1+14) - 6612 FORMAT (/11X,'NH',F9.5,4X,15F7.5) - WRITE (KW,6613) QPCOL(47), (QP(47,L),L=LL1,LL1+14) - 6613 FORMAT (/11X,'SH',F9.5,4X,15F7.5) - WRITE (KW,6614) QPCOL(49), (QP(49,L),L=LL1,LL1+14) - 6614 FORMAT (/7X,'GLOBAL',F9.5,4X,15F7.5) -! - WRITE (KW,6620) INDX, JYRREF, JJDAY, JMONTH, CHAER(KA), & - (PLB0(I),I=LL1,LL1+14), (L,L=LL1,LL1+14) - 6620 FORMAT (/I3,'C=INDEX JYEAR=',I5,' JDAY=',I3, & - ' JMONTH=',I2,T50, & - &' ZONAL MEAN AEROSOL ASYMMETRY PARAMETER',T100, & - A32//21X,'PLB0 =',F6.1,9F7.1, & - &5F7.2/' JLAT DLAT46 COLUMN L =',I4,14I7) -! - DO JJ = 1, 46 - J = 47 - JJ - WRITE (KW,6621) J, DLAT46(J), QGCOL(J), & - (QG(J,L),L=LL1,LL1+14) - 6621 FORMAT (I5,F8.2,F9.5,4X,15F7.5) - ENDDO - WRITE (KW,6622) QGCOL(48), (QG(48,L),L=LL1,LL1+14) - 6622 FORMAT (/11X,'NH',F9.5,4X,15F7.5) - WRITE (KW,6623) QGCOL(47), (QG(47,L),L=LL1,LL1+14) - 6623 FORMAT (/11X,'SH',F9.5,4X,15F7.5) - WRITE (KW,6624) QGCOL(49), (QG(49,L),L=LL1,LL1+14) - 6624 FORMAT (/7X,'GLOBAL',F9.5,4X,15F7.5) - ENDIF - ELSEIF ( INDX/=10 ) THEN -! -!------------- -!------------- -! - KINDEX = INDX - DO I = 1, 5 - WREF(I) = XREF(I) - WPPM(I) = PPMV80(I+4) - ENDDO - WREF(6) = PPMV80(11)*1000.D0 - WREF(7) = PPMV80(12)*1000.D0 - WPPM(1) = PPMV80(2) - WPPM(6) = PPMV80(11) - WPPM(7) = PPMV80(12) -! - YREF11 = PPMV80(11) - ZREF12 = PPMV80(12) -! - JJDAYG = 184 -! - IF ( KINDEX==1 ) THEN - WRITE (KW,6101) JJDAYG - 6101 FORMAT (/1X,'(1)=INDEX',T12,'JDAY=',I3, & - &' RCM RAD EQUIL NO-FEEDBACK DT0',T55, & - &'PRESENT TREND UPDGHG INPUT DATA TO GCM',T96, & - &'FULGAS FACTOR RELATIVE TO 1980 AMOUNTS') - WRITE (KW,6102) KTREND - 6102 FORMAT (1X,'KTREND=',I2,1X,40('-'),3X,38('-'),3X,38('-') & - /1X, & - &'YEAR DTSUM *DTCO2 DTN2O DTCH4 DTF11 DTF12'& - ,' PPMCO2 PPMN20 PPMCH4 PPBF11 PPBF12', & - &' FULCO2 FULN2O FULCH4 FULF11 FULF12') - ENDIF -! - IF ( KINDEX==2 ) THEN - WRITE (KW,6201) JJDAYG - 6201 FORMAT (/1X,'(2)=INDEX',T12,'JDAY=',I3, & - &' RCM EQ NO-FEEDBACK DFLUX W/M2',T55, & - &'PRESENT TREND UPDGHG INPUT DATA TO GCM',T96, & - &'ANNUAL CHANGE RATE OF TRACE GAS AMOUNT') - WRITE (KW,6202) KTREND - 6202 FORMAT (1X,'KTREND=',I2,1X,40('-'),3X,38('-'),3X,38('-') & - /1X, & - &'YEAR DTSUM *DTCO2 DTN2O DTCH4 DTF11 DTF12'& - ,' PPMCO2 PPMN20 PPMCH4 PPBF11 PPBF12', & - &' RATCO2 RATN2O RATCH4 RATF11 RATF12') - ENDIF -! - JYEARG = JYRREF - 1 - CALL UPDGHG(JYEARG,JJDAYG) -! - DO I = 1, 5 - WDAT(I) = XNOW(I) - ENDDO -! - DO J = JYRREF, JYRNOW - KWSKIP = 0 - IF ( J>JYRREF ) KWSKIP = KLIMIT - IF ( J==1980 ) KWSKIP = 0 - IF ( J==JYRNOW ) KWSKIP = 0 - JYEARG = J - CALL UPDGHG(JYEARG,JJDAYG) - DO I = 1, 5 - XRAT(I) = (XNOW(I)-WDAT(I))/(1.D-10+WDAT(I)) - IF ( XRAT(I)>9.9999 ) XRAT(I) = 9.9999 - WDAT(I) = XNOW(I) - ENDDO - IYEAR = JYEARG - IF ( KINDEX==1 ) THEN - IF ( KWSKIP==0 ) WRITE (KW,6103) IYEAR, & - (XNOW(I),I=1,5), FULGAS(2), (FULGAS(I),I=6,9) - 6103 FORMAT (1X,I4,1X,F8.2,4F8.4,1X,5F8.4) - ENDIF - IF ( KINDEX==2 ) THEN - IF ( KWSKIP==0 ) WRITE (KW,6203) IYEAR, & - (XNOW(I),I=1,5), (XRAT(I),I=1,5) - 6203 FORMAT (1X,I4,1X,F8.2,4F8.4,1X,5F8.4) - ENDIF - NSPACE = IYEAR - (IYEAR/10)*10 - IF ( KLIMIT<=0 ) THEN - IF ( NSPACE==0 ) WRITE (KW,6104) - 6104 FORMAT (' ') - ENDIF - ENDDO - ENDIF -! -! - ENDDO - 6402 FORMAT (' ') -! - END SUBROUTINE WRITET - - END MODULE RADPAR - - SUBROUTINE GTREND(XNOW,TNOW) -! - USE RADPAR, ONLY:NGHG, ghgyr1, ghgyr2, ghgam - IMPLICIT NONE - REAL*8 xnow(NGHG), tnow, year, dy, frac - INTEGER iy, n -! -!------------------------------------------------------------- -! Makiko GHG Trend Compilation GHG.1850-2050.Dec1999 -! -! Annual-Mean Greenhouse Gas Mixing Ratios -!------------------------------------------------------------- -! CO2 N2O CH4 CFC-11 CFC-12 others -! Year ppm ppm ppm ppb ppb ppb -!------------------------------------------------------------- -! Read from external file - outside table: use value from -! years ghgyr1 or ghgyr2 - YEAR = TNOW - IF ( TNOW<=ghgyr1+.5D0 ) YEAR = ghgyr1 + .5D0 - IF ( TNOW>=ghgyr2+.49999D0 ) YEAR = ghgyr2 + .49999D0 - DY = YEAR - (ghgyr1+.5D0) - IY = DY - frac = DY - IY - IY = IY + 1 -! -! CO2 N2O CH4 CFC-11 CFC-12 other_GHG SCENARIO -!-------------------------------------------------- -! - DO n = 1, NGHG - XNOW(N) = GHGAM(N,IY) + frac*(GHGAM(N,IY+1)-GHGAM(N,IY)) - ENDDO -! - END SUBROUTINE GTREND diff --git a/model/SUBDD.f b/model/SUBDD.f index 3ec75e3..ee7f613 100644 --- a/model/SUBDD.f +++ b/model/SUBDD.f @@ -1824,17 +1824,12 @@ subroutine parse_subdd catshapes(k) = 'aijlh'; categories(k) = 'taijlh' input_sizes3(k) = lm call tijlh_defs(diaglists(1,k),nmax_possible,diaglens(k)) -#endif -#ifdef TRACERS_GC k = k + 1 catshapes(k) = 'aijlh'; categories(k) = 'taijlh' input_sizes3(k) = lm call tijlh_defs(diaglists(1,k),nmax_possible,diaglens(k)) -#endif -#ifdef TRACERS_GC - k = k + 1 catshapes(k) = 'aijlh'; categories(k) = 'taijlh' input_sizes3(k) = lm @@ -1844,10 +1839,9 @@ subroutine parse_subdd catshapes(k) = 'aijh'; categories(k) = 'taijh' input_sizes3(k) = 0 call tijh_defs(diaglists(1,k),nmax_possible,diaglens(k)) - #endif - + c c check whether each requested diagnostic is in the list c of declared possible outputs