diff --git a/main/CoLM.F90 b/main/CoLM.F90 index dd8608d2..b2fb6fab 100644 --- a/main/CoLM.F90 +++ b/main/CoLM.F90 @@ -120,456 +120,458 @@ PROGRAM CoLM integer*8 :: start_time, end_time, c_per_sec, time_used #ifdef USEMPI - CALL spmd_init () + CALL spmd_init () #endif - CALL getarg (1, nlfile) + CALL getarg (1, nlfile) - CALL read_namelist (nlfile) + CALL read_namelist (nlfile) #ifdef USEMPI - IF (DEF_HIST_WriteBack) THEN - CALL spmd_assign_writeback () - ENDIF + IF (DEF_HIST_WriteBack) THEN + CALL spmd_assign_writeback () + ENDIF - IF (p_is_writeback) THEN - CALL hist_writeback_daemon () - ELSE + IF (p_is_writeback) THEN + CALL hist_writeback_daemon () + ELSE #endif - IF (p_is_master) THEN - CALL system_clock (start_time) - ENDIF + IF (p_is_master) THEN + CALL system_clock (start_time) + ENDIF - casename = DEF_CASE_NAME - dir_landdata = DEF_dir_landdata - dir_forcing = DEF_dir_forcing - dir_hist = DEF_dir_history - dir_restart = DEF_dir_restart + casename = DEF_CASE_NAME + dir_landdata = DEF_dir_landdata + dir_forcing = DEF_dir_forcing + dir_hist = DEF_dir_history + dir_restart = DEF_dir_restart #ifdef SinglePoint - fsrfdata = trim(dir_landdata) // '/srfdata.nc' + fsrfdata = trim(dir_landdata) // '/srfdata.nc' #ifndef URBAN_MODEL - CALL read_surface_data_single (fsrfdata, mksrfdata=.false.) + CALL read_surface_data_single (fsrfdata, mksrfdata=.false.) #else - CALL read_urban_surface_data_single (fsrfdata, mksrfdata=.false., mkrun=.true.) + CALL read_urban_surface_data_single (fsrfdata, mksrfdata=.false., mkrun=.true.) #endif #endif - deltim = DEF_simulation_time%timestep - greenwich = DEF_simulation_time%greenwich - s_year = DEF_simulation_time%start_year - s_month = DEF_simulation_time%start_month - s_day = DEF_simulation_time%start_day - s_seconds = DEF_simulation_time%start_sec - e_year = DEF_simulation_time%end_year - e_month = DEF_simulation_time%end_month - e_day = DEF_simulation_time%end_day - e_seconds = DEF_simulation_time%end_sec - p_year = DEF_simulation_time%spinup_year - p_month = DEF_simulation_time%spinup_month - p_day = DEF_simulation_time%spinup_day - p_seconds = DEF_simulation_time%spinup_sec + deltim = DEF_simulation_time%timestep + greenwich = DEF_simulation_time%greenwich + s_year = DEF_simulation_time%start_year + s_month = DEF_simulation_time%start_month + s_day = DEF_simulation_time%start_day + s_seconds = DEF_simulation_time%start_sec + e_year = DEF_simulation_time%end_year + e_month = DEF_simulation_time%end_month + e_day = DEF_simulation_time%end_day + e_seconds = DEF_simulation_time%end_sec + p_year = DEF_simulation_time%spinup_year + p_month = DEF_simulation_time%spinup_month + p_day = DEF_simulation_time%spinup_day + p_seconds = DEF_simulation_time%spinup_sec - spinup_repeat = DEF_simulation_time%spinup_repeat + spinup_repeat = DEF_simulation_time%spinup_repeat - CALL initimetype(greenwich) - CALL monthday2julian(s_year,s_month,s_day,s_julian) - CALL monthday2julian(e_year,e_month,e_day,e_julian) - CALL monthday2julian(p_year,p_month,p_day,p_julian) + CALL initimetype(greenwich) + CALL monthday2julian(s_year,s_month,s_day,s_julian) + CALL monthday2julian(e_year,e_month,e_day,e_julian) + CALL monthday2julian(p_year,p_month,p_day,p_julian) - sdate(1) = s_year; sdate(2) = s_julian; sdate(3) = s_seconds - edate(1) = e_year; edate(2) = e_julian; edate(3) = e_seconds - pdate(1) = p_year; pdate(2) = p_julian; pdate(3) = p_seconds + sdate(1) = s_year; sdate(2) = s_julian; sdate(3) = s_seconds + edate(1) = e_year; edate(2) = e_julian; edate(3) = e_seconds + pdate(1) = p_year; pdate(2) = p_julian; pdate(3) = p_seconds - CALL Init_GlobalVars - CAll Init_LC_Const - CAll Init_PFT_Const + CALL Init_GlobalVars + CAll Init_LC_Const + CAll Init_PFT_Const - CALL pixel%load_from_file (dir_landdata) - CALL gblock%load_from_file (dir_landdata) + CALL pixel%load_from_file (dir_landdata) + CALL gblock%load_from_file (dir_landdata) #ifdef LULCC - lc_year = s_year + lc_year = s_year #else - lc_year = DEF_LC_YEAR + lc_year = DEF_LC_YEAR #endif - CALL mesh_load_from_file (dir_landdata, lc_year) + CALL mesh_load_from_file (dir_landdata, lc_year) - CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , lc_year) + CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , lc_year) #ifdef CATCHMENT - CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , lc_year) + CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , lc_year) #endif - CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, lc_year) + CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, lc_year) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , lc_year) - CALL map_patch_to_pft + CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , lc_year) + CALL map_patch_to_pft #endif #ifdef URBAN_MODEL - CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, lc_year) - CALL map_patch_to_urban + CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, lc_year) + CALL map_patch_to_urban #endif #if (defined UNSTRUCTURED || defined CATCHMENT) - CALL elm_vector_init () + CALL elm_vector_init () #ifdef CATCHMENT - CALL hru_vector_init () + CALL hru_vector_init () #endif #endif - CALL adj2end(sdate) - CALL adj2end(edate) - CALL adj2end(pdate) + CALL adj2end(sdate) + CALL adj2end(edate) + CALL adj2end(pdate) - ststamp = sdate - etstamp = edate - ptstamp = pdate + ststamp = sdate + etstamp = edate + ptstamp = pdate - ! date in beginning style - jdate = sdate - CALL adj2begin(jdate) + ! date in beginning style + jdate = sdate + CALL adj2begin(jdate) - IF (ptstamp <= ststamp) THEN - spinup_repeat = 0 - ELSE - spinup_repeat = max(0, spinup_repeat) - ENDIF + IF (ptstamp <= ststamp) THEN + spinup_repeat = 0 + ELSE + spinup_repeat = max(0, spinup_repeat) + ENDIF - ! ---------------------------------------------------------------------- - ! Read in the model time invariant constant data - CALL allocate_TimeInvariants () - CALL READ_TimeInvariants (lc_year, casename, dir_restart) + ! ---------------------------------------------------------------------- + ! Read in the model time invariant constant data + CALL allocate_TimeInvariants () + CALL READ_TimeInvariants (lc_year, casename, dir_restart) - ! Read in the model time varying data (model state variables) - CALL allocate_TimeVariables () - CALL READ_TimeVariables (jdate, lc_year, casename, dir_restart) + ! Read in the model time varying data (model state variables) + CALL allocate_TimeVariables () + CALL READ_TimeVariables (jdate, lc_year, casename, dir_restart) - ! Read in SNICAR optical and aging parameters - CALL SnowOptics_init( DEF_file_snowoptics ) ! SNICAR optical parameters - CALL SnowAge_init( DEF_file_snowaging ) ! SNICAR aging parameters + ! Read in SNICAR optical and aging parameters + CALL SnowOptics_init( DEF_file_snowoptics ) ! SNICAR optical parameters + CALL SnowAge_init( DEF_file_snowaging ) ! SNICAR aging parameters - ! ---------------------------------------------------------------------- - doalb = .true. - dolai = .true. - dosst = .false. + ! ---------------------------------------------------------------------- + doalb = .true. + dolai = .true. + dosst = .false. - ! Initialize meteorological forcing data module - CALL allocate_1D_Forcing () - CALL forcing_init (dir_forcing, deltim, ststamp, lc_year, etstamp) - CALL allocate_2D_Forcing (gforc) + ! Initialize meteorological forcing data module + CALL allocate_1D_Forcing () + CALL forcing_init (dir_forcing, deltim, ststamp, lc_year, etstamp) + CALL allocate_2D_Forcing (gforc) - ! Initialize history data module - CALL hist_init (dir_hist) - CALL allocate_1D_Fluxes () + ! Initialize history data module + CALL hist_init (dir_hist) + CALL allocate_1D_Fluxes () #if(defined CaMa_Flood) - CALL colm_CaMa_init !initialize CaMa-Flood + CALL colm_CaMa_init !initialize CaMa-Flood #endif - IF(DEF_USE_OZONEDATA)THEN - CALL init_Ozone_data (sdate) - ENDIF + IF(DEF_USE_OZONEDATA)THEN + CALL init_Ozone_data (sdate) + ENDIF - ! Initialize aerosol deposition forcing data - IF (DEF_Aerosol_Readin) THEN - CALL AerosolDepInit () - ENDIF + ! Initialize aerosol deposition forcing data + IF (DEF_Aerosol_Readin) THEN + CALL AerosolDepInit () + ENDIF #ifdef BGC - IF (DEF_USE_NITRIF) THEN - CALL init_nitrif_data (sdate) - ENDIF + IF (DEF_USE_NITRIF) THEN + CALL init_nitrif_data (sdate) + ENDIF - IF (DEF_NDEP_FREQUENCY==1)THEN ! Initial annual ndep data readin - CALL init_ndep_data_annually (sdate(1)) - ELSEIF(DEF_NDEP_FREQUENCY==2)THEN ! Initial monthly ndep data readin - CALL init_ndep_data_monthly (sdate(1),s_month) ! sf_add - ELSE - write(6,*) 'ERROR: DEF_NDEP_FREQUENCY should be only 1-2, Current is:',DEF_NDEP_FREQUENCY - CALL CoLM_stop () - ENDIF + IF (DEF_NDEP_FREQUENCY==1)THEN ! Initial annual ndep data readin + CALL init_ndep_data_annually (sdate(1)) + ELSEIF(DEF_NDEP_FREQUENCY==2)THEN ! Initial monthly ndep data readin + CALL init_ndep_data_monthly (sdate(1),s_month) ! sf_add + ELSE + write(6,*) 'ERROR: DEF_NDEP_FREQUENCY should be only 1-2, Current is:', & + DEF_NDEP_FREQUENCY + CALL CoLM_stop () + ENDIF - IF (DEF_USE_FIRE) THEN - CALL init_fire_data (sdate(1)) - CALL init_lightning_data (sdate) - ENDIF + IF (DEF_USE_FIRE) THEN + CALL init_fire_data (sdate(1)) + CALL init_lightning_data (sdate) + ENDIF #endif #if (defined CatchLateralFlow) - CALL lateral_flow_init (lc_year) + CALL lateral_flow_init (lc_year) #endif #ifdef DataAssimilation - CALL init_DataAssimilation () + CALL init_DataAssimilation () #endif - ! ====================================================================== - ! begin time stepping loop - ! ====================================================================== + ! ====================================================================== + ! begin time stepping loop + ! ====================================================================== - istep = 1 - idate = sdate - itstamp = ststamp + istep = 1 + idate = sdate + itstamp = ststamp - TIMELOOP : DO WHILE (itstamp < etstamp) + TIMELOOP : DO WHILE (itstamp < etstamp) - CALL julian2monthday (jdate(1), jdate(2), month_p, mday_p) + CALL julian2monthday (jdate(1), jdate(2), month_p, mday_p) - year_p = jdate(1) + year_p = jdate(1) - IF (p_is_master) THEN - IF (itstamp < ptstamp) THEN - write(*, 99) istep, jdate(1), month_p, mday_p, jdate(3), spinup_repeat - ELSE - write(*,100) istep, jdate(1), month_p, mday_p, jdate(3) + IF (p_is_master) THEN + IF (itstamp < ptstamp) THEN + write(*, 99) istep, jdate(1), month_p, mday_p, jdate(3), spinup_repeat + ELSE + write(*,100) istep, jdate(1), month_p, mday_p, jdate(3) + ENDIF ENDIF - ENDIF - Julian_1day_p = int(calendarday(jdate)-1)/1*1 + 1 - Julian_8day_p = int(calendarday(jdate)-1)/8*8 + 1 + Julian_1day_p = int(calendarday(jdate)-1)/1*1 + 1 + Julian_8day_p = int(calendarday(jdate)-1)/8*8 + 1 - ! Read in the meteorological forcing - ! ---------------------------------------------------------------------- - CALL read_forcing (jdate, dir_forcing) + ! Read in the meteorological forcing + ! ---------------------------------------------------------------------- + CALL read_forcing (jdate, dir_forcing) - IF(DEF_USE_OZONEDATA)THEN - CALL update_Ozone_data(itstamp, deltim) - ENDIF + IF(DEF_USE_OZONEDATA)THEN + CALL update_Ozone_data(itstamp, deltim) + ENDIF #ifdef BGC - IF(DEF_USE_FIRE)THEN - CALL update_lightning_data (itstamp, deltim) - ENDIF + IF(DEF_USE_FIRE)THEN + CALL update_lightning_data (itstamp, deltim) + ENDIF #endif - ! Read in aerosol deposition forcing data - IF (DEF_Aerosol_Readin) THEN - CALL AerosolDepReadin (jdate) - ENDIF + ! Read in aerosol deposition forcing data + IF (DEF_Aerosol_Readin) THEN + CALL AerosolDepReadin (jdate) + ENDIF - ! Calendar for NEXT time step - ! ---------------------------------------------------------------------- - CALL TICKTIME (deltim,idate) - itstamp = itstamp + int(deltim) - jdate = idate - CALL adj2begin(jdate) + ! Calendar for NEXT time step + ! ---------------------------------------------------------------------- + CALL TICKTIME (deltim,idate) + itstamp = itstamp + int(deltim) + jdate = idate + CALL adj2begin(jdate) - CALL julian2monthday (jdate(1), jdate(2), month, mday) + CALL julian2monthday (jdate(1), jdate(2), month, mday) #ifdef BGC - IF(DEF_USE_NITRIF) THEN - IF (month /= month_p) THEN - CALL update_nitrif_data (month) + IF(DEF_USE_NITRIF) THEN + IF (month /= month_p) THEN + CALL update_nitrif_data (month) + ENDIF ENDIF - ENDIF - IF (DEF_NDEP_FREQUENCY==1)THEN ! Read Annual Ndep data - IF (jdate(1) /= year_p) THEN - CALL update_ndep_data_annually (idate(1), iswrite = .true.) - ENDIF - ELSEIF(DEF_NDEP_FREQUENCY==2)THEN! Read Monthly Ndep data - IF (jdate(1) /= year_p .or. month /= month_p) THEN !sf_add - CALL update_ndep_data_monthly (jdate(1), month, iswrite = .true.) !sf_add + IF (DEF_NDEP_FREQUENCY==1)THEN ! Read Annual Ndep data + IF (jdate(1) /= year_p) THEN + CALL update_ndep_data_annually (idate(1), iswrite = .true.) + ENDIF + ELSEIF(DEF_NDEP_FREQUENCY==2)THEN! Read Monthly Ndep data + IF (jdate(1) /= year_p .or. month /= month_p) THEN !sf_add + CALL update_ndep_data_monthly (jdate(1), month, iswrite = .true.) !sf_add + ENDIF + ELSE + write(6,*) 'ERROR: DEF_NDEP_FREQUENCY should be only 1-2, Current is:',& + DEF_NDEP_FREQUENCY + CALL CoLM_stop () ENDIF - ELSE - write(6,*) 'ERROR: DEF_NDEP_FREQUENCY should be only 1-2, Current is:',DEF_NDEP_FREQUENCY - CALL CoLM_stop () - ENDIF - IF(DEF_USE_FIRE)THEN - IF (jdate(1) /= year_p) THEN - CALL update_hdm_data (idate(1)) + IF(DEF_USE_FIRE)THEN + IF (jdate(1) /= year_p) THEN + CALL update_hdm_data (idate(1)) + ENDIF ENDIF - ENDIF #endif - ! Call colm driver - ! ---------------------------------------------------------------------- - IF (p_is_worker) THEN - CALL CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oroflag) - ENDIF + ! Call colm driver + ! ---------------------------------------------------------------------- + IF (p_is_worker) THEN + CALL CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oroflag) + ENDIF #if (defined CatchLateralFlow) - CALL lateral_flow (deltim) + CALL lateral_flow (deltim) #endif #if(defined CaMa_Flood) - CALL colm_CaMa_drv(idate(3)) ! run CaMa-Flood + CALL colm_CaMa_drv(idate(3)) ! run CaMa-Flood #endif #ifdef DataAssimilation - CALL do_DataAssimilation (idate, deltim) + CALL do_DataAssimilation (idate, deltim) #endif - ! Write out the model variables for restart run and the histroy file - ! ---------------------------------------------------------------------- - CALL hist_out (idate, deltim, itstamp, etstamp, ptstamp, dir_hist, casename) + ! Write out the model variables for restart run and the histroy file + ! ---------------------------------------------------------------------- + CALL hist_out (idate, deltim, itstamp, etstamp, ptstamp, dir_hist, casename) - ! DO land USE and land cover change simulation - ! ---------------------------------------------------------------------- + ! DO land USE and land cover change simulation + ! ---------------------------------------------------------------------- #ifdef LULCC - IF ( isendofyear(idate, deltim) ) THEN - CALL deallocate_1D_Forcing - CALL deallocate_1D_Fluxes - - CALL LulccDriver (casename,dir_landdata,dir_restart,& - idate,greenwich) - - CALL allocate_1D_Forcing - CALL forcing_init (dir_forcing, deltim, itstamp, jdate(1)) - CALL deallocate_acc_fluxes - CALL hist_init (dir_hist) - CALL allocate_1D_Fluxes - ENDIF + IF ( isendofyear(idate, deltim) ) THEN + CALL deallocate_1D_Forcing + CALL deallocate_1D_Fluxes + + CALL LulccDriver (casename,dir_landdata,dir_restart,& + idate,greenwich) + + CALL allocate_1D_Forcing + CALL forcing_init (dir_forcing, deltim, itstamp, jdate(1)) + CALL deallocate_acc_fluxes + CALL hist_init (dir_hist) + CALL allocate_1D_Fluxes + ENDIF #endif - ! Get leaf area index - ! ---------------------------------------------------------------------- + ! Get leaf area index + ! ---------------------------------------------------------------------- #if(defined DYN_PHENOLOGY) - ! Update once a day - dolai = .false. - Julian_1day = int(calendarday(jdate)-1)/1*1 + 1 - IF(Julian_1day /= Julian_1day_p)THEN - dolai = .true. - ENDIF + ! Update once a day + dolai = .false. + Julian_1day = int(calendarday(jdate)-1)/1*1 + 1 + IF(Julian_1day /= Julian_1day_p)THEN + dolai = .true. + ENDIF #else - ! READ in Leaf area index and stem area index - ! ---------------------------------------------------------------------- - ! Hua Yuan, 08/03/2019: read global monthly LAI/SAI data - ! zhongwang wei, 20210927: add option to read non-climatological mean LAI - ! Update every 8 days (time interval of the MODIS LAI data) - ! Hua Yuan, 06/2023: change namelist DEF_LAI_CLIM to DEF_LAI_MONTHLY - ! and add DEF_LAI_CHANGE_YEARLY for monthly LAI data - ! - ! NOTES: Should be caution for setting DEF_LAI_CHANGE_YEARLY to ture in non-LULCC - ! case, that means the LAI changes without condisderation of land cover change. - - IF (DEF_LAI_CHANGE_YEARLY) THEN - lai_year = jdate(1) - ELSE - lai_year = DEF_LC_YEAR - ENDIF + ! READ in Leaf area index and stem area index + ! ---------------------------------------------------------------------- + ! Hua Yuan, 08/03/2019: read global monthly LAI/SAI data + ! zhongwang wei, 20210927: add option to read non-climatological mean LAI + ! Update every 8 days (time interval of the MODIS LAI data) + ! Hua Yuan, 06/2023: change namelist DEF_LAI_CLIM to DEF_LAI_MONTHLY + ! and add DEF_LAI_CHANGE_YEARLY for monthly LAI data + ! + ! NOTES: Should be caution for setting DEF_LAI_CHANGE_YEARLY to ture in non-LULCC + ! case, that means the LAI changes without condisderation of land cover change. + + IF (DEF_LAI_CHANGE_YEARLY) THEN + lai_year = jdate(1) + ELSE + lai_year = DEF_LC_YEAR + ENDIF - IF (DEF_LAI_MONTHLY) THEN - IF ((itstamp < etstamp) .and. (month /= month_p)) THEN - CALL LAI_readin (lai_year, month, dir_landdata) + IF (DEF_LAI_MONTHLY) THEN + IF ((itstamp < etstamp) .and. (month /= month_p)) THEN + CALL LAI_readin (lai_year, month, dir_landdata) #ifdef URBAN_MODEL - CALL UrbanLAI_readin(lai_year, month, dir_landdata) + CALL UrbanLAI_readin(lai_year, month, dir_landdata) #endif + ENDIF + ELSE + ! Update every 8 days (time interval of the MODIS LAI data) + Julian_8day = int(calendarday(jdate)-1)/8*8 + 1 + IF ((itstamp < etstamp) .and. (Julian_8day /= Julian_8day_p)) THEN + CALL LAI_readin (jdate(1), Julian_8day, dir_landdata) + ! 06/2023, yuan: or depend on DEF_LAI_CHANGE_YEARLY nanemlist + !CALL LAI_readin (lai_year, Julian_8day, dir_landdata) + ENDIF ENDIF - ELSE - ! Update every 8 days (time interval of the MODIS LAI data) - Julian_8day = int(calendarday(jdate)-1)/8*8 + 1 - IF ((itstamp < etstamp) .and. (Julian_8day /= Julian_8day_p)) THEN - CALL LAI_readin (jdate(1), Julian_8day, dir_landdata) - ! 06/2023, yuan: or depend on DEF_LAI_CHANGE_YEARLY nanemlist - !CALL LAI_readin (lai_year, Julian_8day, dir_landdata) - ENDIF - ENDIF #endif - IF (save_to_restart (idate, deltim, itstamp, ptstamp)) THEN + IF (save_to_restart (idate, deltim, itstamp, ptstamp)) THEN #ifdef LULCC - CALL WRITE_TimeVariables (jdate, jdate(1), casename, dir_restart) + CALL WRITE_TimeVariables (jdate, jdate(1), casename, dir_restart) #else - CALL WRITE_TimeVariables (jdate, lc_year, casename, dir_restart) + CALL WRITE_TimeVariables (jdate, lc_year, casename, dir_restart) #endif #if(defined CaMa_Flood) - IF (p_is_master) THEN - CALL colm_cama_write_restart (jdate, lc_year, casename, dir_restart) - ENDIF + IF (p_is_master) THEN + CALL colm_cama_write_restart (jdate, lc_year, casename, dir_restart) + ENDIF #endif - ENDIF + ENDIF #ifdef RangeCheck - CALL check_TimeVariables () + CALL check_TimeVariables () #endif #ifdef CoLMDEBUG - CALL print_VSF_iteration_stat_info () + CALL print_VSF_iteration_stat_info () #endif #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN - CALL system_clock (end_time, count_rate = c_per_sec) - time_used = (end_time - start_time) / c_per_sec - IF (time_used >= 3600) THEN - write(*,101) time_used/3600, mod(time_used,3600)/60, mod(time_used,60) - ELSEIF (time_used >= 60) THEN - write(*,102) time_used/60, mod(time_used,60) - ELSE - write(*,103) time_used + IF (p_is_master) THEN + CALL system_clock (end_time, count_rate = c_per_sec) + time_used = (end_time - start_time) / c_per_sec + IF (time_used >= 3600) THEN + write(*,101) time_used/3600, mod(time_used,3600)/60, mod(time_used,60) + ELSEIF (time_used >= 60) THEN + write(*,102) time_used/60, mod(time_used,60) + ELSE + write(*,103) time_used + ENDIF ENDIF - ENDIF - IF ((spinup_repeat > 1) .and. (ptstamp <= itstamp)) THEN - spinup_repeat = spinup_repeat - 1 - idate = sdate - jdate = sdate - itstamp = ststamp - CALL adj2begin(jdate) - CALL forcing_reset () - ENDIF + IF ((spinup_repeat > 1) .and. (ptstamp <= itstamp)) THEN + spinup_repeat = spinup_repeat - 1 + idate = sdate + jdate = sdate + itstamp = ststamp + CALL adj2begin(jdate) + CALL forcing_reset () + ENDIF - istep = istep + 1 + istep = istep + 1 - ENDDO TIMELOOP + ENDDO TIMELOOP - CALL deallocate_TimeInvariants () - CALL deallocate_TimeVariables () - CALL deallocate_1D_Forcing () - CALL deallocate_1D_Fluxes () + CALL deallocate_TimeInvariants () + CALL deallocate_TimeVariables () + CALL deallocate_1D_Forcing () + CALL deallocate_1D_Fluxes () #if (defined CatchLateralFlow) - CALL lateral_flow_final () + CALL lateral_flow_final () #endif - CALL forcing_final () - CALL hist_final () + CALL forcing_final () + CALL hist_final () #ifdef SinglePoint - CALL single_srfdata_final () + CALL single_srfdata_final () #endif #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif #if(defined CaMa_Flood) - CALL colm_cama_exit ! finalize CaMa-Flood + CALL colm_cama_exit ! finalize CaMa-Flood #endif #ifdef DataAssimilation - CALL final_DataAssimilation () + CALL final_DataAssimilation () #endif - IF (p_is_master) THEN - write(*,'(/,A25)') 'CoLM Execution Completed.' - ENDIF + IF (p_is_master) THEN + write(*,'(/,A25)') 'CoLM Execution Completed.' + ENDIF - 99 format(/, 'TIMESTEP = ', I0, ' | DATE = ', I4.4, '-', I2.2, '-', I2.2, '-', I5.5, ' Spinup (', I0, ' repeat left)') - 100 format(/, 'TIMESTEP = ', I0, ' | DATE = ', I4.4, '-', I2.2, '-', I2.2, '-', I5.5) - 101 format(/, 'Time elapsed : ', I4, ' hours', I3, ' minutes', I3, ' seconds.') - 102 format(/, 'Time elapsed : ', I3, ' minutes', I3, ' seconds.') - 103 format(/, 'Time elapsed : ', I3, ' seconds.') + 99 format(/, 'TIMESTEP = ', I0, ' | DATE = ', I4.4, '-', I2.2, '-', I2.2, '-', I5.5, ' Spinup (', I0, ' repeat left)') + 100 format(/, 'TIMESTEP = ', I0, ' | DATE = ', I4.4, '-', I2.2, '-', I2.2, '-', I5.5) + 101 format(/, 'Time elapsed : ', I4, ' hours', I3, ' minutes', I3, ' seconds.') + 102 format(/, 'Time elapsed : ', I3, ' minutes', I3, ' seconds.') + 103 format(/, 'Time elapsed : ', I3, ' seconds.') #ifdef USEMPI - ENDIF + ENDIF - IF (DEF_HIST_WriteBack) THEN - CALL hist_writeback_exit () - ENDIF + IF (DEF_HIST_WriteBack) THEN + CALL hist_writeback_exit () + ENDIF - CALL spmd_exit + CALL spmd_exit #endif END PROGRAM CoLM diff --git a/main/CoLMDRIVER.F90 b/main/CoLMDRIVER.F90 index 8625629c..542a045e 100644 --- a/main/CoLMDRIVER.F90 +++ b/main/CoLMDRIVER.F90 @@ -53,277 +53,277 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) !$OMP SCHEDULE(STATIC, 1) #endif - DO i = 1, numpatch + DO i = 1, numpatch - ! Apply forcing mask - IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask(i)) CYCLE - ENDIF + ! Apply forcing mask + IF (DEF_forcing%has_missing_value) THEN + IF (.not. forcmask(i)) CYCLE + ENDIF - ! Apply patch mask - IF (.not. patchmask(i)) CYCLE + ! Apply patch mask + IF (.not. patchmask(i)) CYCLE - m = patchclass(i) + m = patchclass(i) - steps_in_one_deltim = 1 - ! deltim need to be within 1800s for waterbody with snow in order to avoid large - ! temperature fluctuations due to rapid snow heat conductance - IF(m == WATERBODY .and. snowdp(i) > 0.0) steps_in_one_deltim = ceiling(deltim/1800.) - deltim_phy = deltim/steps_in_one_deltim + steps_in_one_deltim = 1 + ! deltim need to be within 1800s for waterbody with snow in order to avoid large + ! temperature fluctuations due to rapid snow heat conductance + IF(m == WATERBODY .and. snowdp(i) > 0.0) steps_in_one_deltim = ceiling(deltim/1800.) + deltim_phy = deltim/steps_in_one_deltim - ! For non urban patch or slab urban - IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN + ! For non urban patch or slab urban + IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN - DO k = 1, steps_in_one_deltim - ! ***** Call CoLM main program ***** - ! - CALL CoLMMAIN (i,idate, coszen(i), deltim_phy, & - patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & - doalb, dolai, dosst, oro(i), & + DO k = 1, steps_in_one_deltim + ! ***** Call CoLM main program ***** + ! + CALL CoLMMAIN (i,idate, coszen(i), deltim_phy, & + patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & + doalb, dolai, dosst, oro(i), & - ! SOIL INFORMATION AND LAKE DEPTH - soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & - vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & - wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & - bsw(1:,i), & + ! SOIL INFORMATION AND LAKE DEPTH + soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & + vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & + wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & + bsw(1:,i), & #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & - sc_vgm (1:,i), fc_vgm (1:,i), & + theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & + sc_vgm (1:,i), fc_vgm (1:,i), & #endif - hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & - dksatf(1:,i), dkdry(1:,i), & - BA_alpha(1:,i), BA_beta(1:,i), & - rootfr(1:,m), lakedepth(i), dz_lake(1:,i), & + hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & + dksatf(1:,i), dkdry(1:,i), & + BA_alpha(1:,i), BA_beta(1:,i), & + rootfr(1:,m), lakedepth(i), dz_lake(1:,i), & #if(defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i),fevpg_fld(i), finfg_fld(i), & + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i),fevpg_fld(i), finfg_fld(i), & #endif - ! VEGETATION INFORMATION - htop(i), hbot(i), sqrtdi(m), & - effcon(m), vmax25(m), & - kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & - psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & - ck(m), & - slti(m), hlti(m), & - shti(m), hhti(m), trda(m), trdm(m), & - trop(m), g1(m), g0(m),gradm(m), binter(m), & - extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & - - ! ATMOSPHERIC FORCING - forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & - forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & - forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & - forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & - forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & - forc_rhoair(i), & - ! CBL height forcing - forc_hpbl(i), & - ! Aerosol deposition - forc_aerdep(:,i), & + ! VEGETATION INFORMATION + htop(i), hbot(i), sqrtdi(m), & + effcon(m), vmax25(m), & + kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & + psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & + ck(m), & + slti(m), hlti(m), & + shti(m), hhti(m), trda(m), trdm(m), & + trop(m), g1(m), g0(m),gradm(m), binter(m), & + extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & + + ! ATMOSPHERIC FORCING + forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & + forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & + forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & + forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & + forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & + forc_rhoair(i), & + ! CBL height forcing + forc_hpbl(i), & + ! Aerosol deposition + forc_aerdep(:,i), & + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & + t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & + wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & + t_grnd(i), tleaf(i), ldew(i),ldew_rain(i),ldew_snow(i),& + sag(i), scv(i), snowdp(i), fveg(i), & + fsno(i), sigf(i), green(i), lai(i), & + sai(i), alb(1:,1:,i), ssun(1:,1:,i), ssha(1:,1:,i), & + ssoi(:,:,i), ssno(:,:,i), thermk(i), extkb(i), & + extkd(i), vegwp(1:,i), gs0sun(i), gs0sha(i), & + ! Ozone Stress Variables + lai_old(i), o3uptakesun(i), o3uptakesha(i) ,forc_ozone(i), & + ! End ozone stress variables + zwt(i), wdsrf(i), wa(i), wetwat(i), & + t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & + + ! SNICAR snow model related + snw_rds(:,i), ssno_lyr(:,:,:,i), & + mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & + mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & + + ! additional diagnostic variables for output + laisun(i), laisha(i), rootr(1:,i),rootflux(1:,i),rss(i),& + rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & + assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & + h2osoi(1:,i), wat(i), & + + ! FLUXES + taux(i), tauy(i), fsena(i), fevpa(i), & + lfevpa(i), fsenl(i), fevpl(i), etr(i), & + fseng(i), fevpg(i), olrg(i), fgrnd(i), & + trad(i), tref(i), qref(i), rsur(i), & + rnof(i), qintr(i), qinfl(i), qdrip(i), & + rst(i), assim(i), respc(i), sabvsun(i), & + sabvsha(i), sabg(i), sr(i), solvd(i), & + solvi(i), solnd(i), solni(i), srvd(i), & + srvi(i), srnd(i), srni(i), solvdln(i), & + solviln(i), solndln(i), solniln(i), srvdln(i), & + srviln(i), srndln(i), srniln(i), qcharge(i), & + xerr(i), zerr(i), & + + ! TUNABLE modle constants + zlnd, zsno, csoilc, dewmx, & + wtfact, capr, cnfac, ssi, & + wimp, pondmx, smpmax, smpmin, & + trsmx0, tcrit, & + + ! additional variables required by coupling with WRF model + emis(i), z0m(i), zol(i), rib(i), & + ustar(i), qstar(i), tstar(i), & + fm(i), fh(i), fq(i) ) + + ENDDO + ENDIF - ! LAND SURFACE VARIABLES REQUIRED FOR RESTART - z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & - t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & - wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & - t_grnd(i), tleaf(i), ldew(i),ldew_rain(i),ldew_snow(i),& - sag(i), scv(i), snowdp(i), fveg(i), & - fsno(i), sigf(i), green(i), lai(i), & - sai(i), alb(1:,1:,i), ssun(1:,1:,i), ssha(1:,1:,i), & - ssoi(:,:,i), ssno(:,:,i), thermk(i), extkb(i), & - extkd(i), vegwp(1:,i), gs0sun(i), gs0sha(i), & - ! Ozone Stress Variables - lai_old(i), o3uptakesun(i), o3uptakesha(i) ,forc_ozone(i), & - ! End ozone stress variables - zwt(i), wdsrf(i), wa(i), wetwat(i), & - t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & - ! SNICAR snow model related - snw_rds(:,i), ssno_lyr(:,:,:,i), & - mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & - mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & +#if(defined BGC) + IF(patchtype(i) .eq. 0)THEN - ! additional diagnostic variables for output - laisun(i), laisha(i), rootr(1:,i),rootflux(1:,i),rss(i),& - rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & - assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & - h2osoi(1:,i), wat(i), & + ! ***** Call CoLM BGC model ***** + ! + CALL bgc_driver (i,idate(1:3),deltim, patchlatr(i)*180/PI,patchlonr(i)*180/PI) + ENDIF +#endif - ! FLUXES - taux(i), tauy(i), fsena(i), fevpa(i), & - lfevpa(i), fsenl(i), fevpl(i), etr(i), & - fseng(i), fevpg(i), olrg(i), fgrnd(i), & - trad(i), tref(i), qref(i), rsur(i), & - rnof(i), qintr(i), qinfl(i), qdrip(i), & - rst(i), assim(i), respc(i), sabvsun(i), & - sabvsha(i), sabg(i), sr(i), solvd(i), & - solvi(i), solnd(i), solni(i), srvd(i), & - srvi(i), srnd(i), srni(i), solvdln(i), & - solviln(i), solndln(i), solniln(i), srvdln(i), & - srviln(i), srndln(i), srniln(i), qcharge(i), & - xerr(i), zerr(i), & - ! TUNABLE modle constants - zlnd, zsno, csoilc, dewmx, & - wtfact, capr, cnfac, ssi, & - wimp, pondmx, smpmax, smpmin, & - trsmx0, tcrit, & +#ifdef URBAN_MODEL + ! For urban model and urban patches + IF (DEF_URBAN_RUN .and. m.eq.URBAN) THEN - ! additional variables required by coupling with WRF model - emis(i), z0m(i), zol(i), rib(i), & - ustar(i), qstar(i), tstar(i), & - fm(i), fh(i), fq(i) ) + u = patch2urban(i) + !print *, "patch:", i, "urban:", u !fortest only - ENDDO - ENDIF + ! ***** Call CoLM urban model ***** + ! + CALL UrbanCoLMMAIN ( & + ! MODEL RUNNING PARAMETERS + i ,idate ,coszen(i) ,deltim ,& + patchlonr(i) ,patchlatr(i) ,patchclass(i) ,patchtype(i) ,& + + ! URBAN PARAMETERS + froof(u) ,flake(u) ,hroof(u) ,hwr(u) ,& + fgper(u) ,em_roof(u) ,em_wall(u) ,em_gimp(u) ,& + em_gper(u) ,cv_roof(:,u) ,cv_wall(:,u) ,cv_gimp(:,u) ,& + tk_roof(:,u) ,tk_wall(:,u) ,tk_gimp(:,u) ,z_roof(:,u) ,& + z_wall(:,u) ,dz_roof(:,u) ,dz_wall(:,u) ,& + lakedepth(i) ,dz_lake(1:,i) ,& + + ! LUCY INPUT PARAMETERS + fix_holiday(:,u),week_holiday(:,u),hum_prof(:,u) ,pop_den(u) ,& + vehicle(:,u) ,weh_prof(:,u) ,wdh_prof(:,u) ,& + ! SOIL INFORMATION AND LAKE DEPTH + vf_quartz(1:,i) ,vf_gravels(1:,i),vf_om(1:,i) ,vf_sand(1:,i) ,& + wf_gravels(1:,i),wf_sand(1:,i) ,porsl(1:,i) ,psi0(1:,i) ,& + bsw(1:,i) ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r(1:,i) ,alpha_vgm(1:,i) ,n_vgm(1:,i) ,L_vgm(1:,i) ,& + sc_vgm (1:,i) ,fc_vgm (1:,i) ,& +#endif + hksati(1:,i) ,csol(1:,i) ,k_solids(1:,i), dksatu(1:,i) ,& + dksatf(1:,i) ,dkdry(1:,i) ,& + BA_alpha(1:,i) ,BA_beta(1:,i) ,& + alb_roof(:,:,u) ,alb_wall(:,:,u) ,alb_gimp(:,:,u) ,alb_gper(:,:,u) ,& -#if(defined BGC) - IF(patchtype(i) .eq. 0)THEN + ! VEGETATION INFORMATION + htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& + effcon(m) ,vmax25(m) ,slti(m) ,hlti(m) ,& + shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& + trop(m) ,g1(m) ,g0(m),gradm(m) ,binter(m) ,& + extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,rootfr(1:,m) ,& - ! ***** Call CoLM BGC model ***** - ! - CALL bgc_driver (i,idate(1:3),deltim, patchlatr(i)*180/PI,patchlonr(i)*180/PI) - ENDIF -#endif + ! ATMOSPHERIC FORCING + forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& + forc_t(i) ,forc_q(i) ,forc_prc(i) ,forc_prl(i) ,& + forc_rain(i) ,forc_snow(i) ,forc_psrf(i) ,forc_pbot(i) ,& + forc_sols(i) ,forc_soll(i) ,forc_solsd(i) ,forc_solld(i) ,& + forc_frl(i) ,forc_hgt_u(i) ,forc_hgt_t(i) ,forc_hgt_q(i) ,& + forc_rhoair(i) ,Fhac(u) ,Fwst(u) ,Fach(u) ,& + Fahe(u) ,Fhah(u) ,vehc(u) ,meta(u) ,& + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno_roof (maxsnl+1:,u) ,z_sno_gimp (maxsnl+1:,u) ,& + z_sno_gper (maxsnl+1:,u) ,z_sno_lake (maxsnl+1:,u) ,& + dz_sno_roof (maxsnl+1:,u) ,dz_sno_gimp (maxsnl+1:,u) ,& + dz_sno_gper (maxsnl+1:,u) ,dz_sno_lake (maxsnl+1:,u) ,& + t_roofsno (maxsnl+1:,u) ,t_gimpsno (maxsnl+1:,u) ,& + t_gpersno (maxsnl+1:,u) ,t_lakesno (maxsnl+1:,u) ,& + wliq_roofsno(maxsnl+1:,u) ,wliq_gimpsno(maxsnl+1:,u) ,& + wliq_gpersno(maxsnl+1:,u) ,wliq_lakesno(maxsnl+1:,u) ,& + wice_roofsno(maxsnl+1:,u) ,wice_gimpsno(maxsnl+1:,u) ,& + wice_gpersno(maxsnl+1:,u) ,wice_lakesno(maxsnl+1:,u) ,& + z_sno (maxsnl+1:,i) ,dz_sno (maxsnl+1:,i) ,& + wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& + t_soisno (maxsnl+1:,i) ,& + smp (1:,i) ,hk (1:,i) ,& + t_wallsun (1:,u) ,t_wallsha (1:,u) ,& + + lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& + green(i) ,tleaf(i) ,ldew(i) ,t_grnd(i) ,& + + sag_roof(u) ,sag_gimp(u) ,sag_gper(u) ,sag_lake(u) ,& + scv_roof(u) ,scv_gimp(u) ,scv_gper(u) ,scv_lake(u) ,& + snowdp_roof(u) ,snowdp_gimp(u) ,snowdp_gper(u) ,snowdp_lake(u) ,& + fsno_roof(u) ,fsno_gimp(u) ,fsno_gper(u) ,fsno_lake(u) ,& + sag(i) ,scv(i) ,snowdp(i) ,fsno(i) ,& + extkd(i) ,alb(1:,1:,i) ,ssun(1:,1:,i) ,ssha(1:,1:,i) ,& + sroof(1:,1:,u) ,swsun(1:,1:,u) ,swsha(1:,1:,u) ,sgimp(1:,1:,u) ,& + sgper(1:,1:,u) ,slake(1:,1:,u) ,lwsun(u) ,lwsha(u) ,& + lgimp(u) ,lgper(u) ,lveg(u) ,fwsun(u) ,& + dfwsun(u) ,t_room(u) ,troof_inner(u) ,twsun_inner(u) ,& + twsha_inner(u) ,t_roommax(u) ,t_roommin(u) ,tafu(u) ,& + + zwt(i) ,wa(i) ,& + t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& -#ifdef URBAN_MODEL - ! For urban model and urban patches - IF (DEF_URBAN_RUN .and. m.eq.URBAN) THEN - - u = patch2urban(i) - !print *, "patch:", i, "urban:", u !fortest only - - ! ***** Call CoLM urban model ***** - ! - CALL UrbanCoLMMAIN ( & - ! MODEL RUNNING PARAMETERS - i ,idate ,coszen(i) ,deltim ,& - patchlonr(i) ,patchlatr(i) ,patchclass(i) ,patchtype(i) ,& - - ! URBAN PARAMETERS - froof(u) ,flake(u) ,hroof(u) ,hwr(u) ,& - fgper(u) ,em_roof(u) ,em_wall(u) ,em_gimp(u) ,& - em_gper(u) ,cv_roof(:,u) ,cv_wall(:,u) ,cv_gimp(:,u) ,& - tk_roof(:,u) ,tk_wall(:,u) ,tk_gimp(:,u) ,z_roof(:,u) ,& - z_wall(:,u) ,dz_roof(:,u) ,dz_wall(:,u) ,& - lakedepth(i) ,dz_lake(1:,i) ,& - - ! LUCY INPUT PARAMETERS - fix_holiday(:,u),week_holiday(:,u),hum_prof(:,u) ,pop_den(u) ,& - vehicle(:,u) ,weh_prof(:,u) ,wdh_prof(:,u) ,& - - ! SOIL INFORMATION AND LAKE DEPTH - vf_quartz(1:,i) ,vf_gravels(1:,i),vf_om(1:,i) ,vf_sand(1:,i) ,& - wf_gravels(1:,i),wf_sand(1:,i) ,porsl(1:,i) ,psi0(1:,i) ,& - bsw(1:,i) ,& -#ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r(1:,i) ,alpha_vgm(1:,i) ,n_vgm(1:,i) ,L_vgm(1:,i) ,& - sc_vgm (1:,i) ,fc_vgm (1:,i) ,& -#endif - hksati(1:,i) ,csol(1:,i) ,k_solids(1:,i), dksatu(1:,i) ,& - dksatf(1:,i) ,dkdry(1:,i) ,& - BA_alpha(1:,i) ,BA_beta(1:,i) ,& - alb_roof(:,:,u) ,alb_wall(:,:,u) ,alb_gimp(:,:,u) ,alb_gper(:,:,u) ,& - - ! VEGETATION INFORMATION - htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& - effcon(m) ,vmax25(m) ,slti(m) ,hlti(m) ,& - shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& - trop(m) ,g1(m) ,g0(m),gradm(m) ,binter(m) ,& - extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,rootfr(1:,m) ,& - - ! ATMOSPHERIC FORCING - forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& - forc_t(i) ,forc_q(i) ,forc_prc(i) ,forc_prl(i) ,& - forc_rain(i) ,forc_snow(i) ,forc_psrf(i) ,forc_pbot(i) ,& - forc_sols(i) ,forc_soll(i) ,forc_solsd(i) ,forc_solld(i) ,& - forc_frl(i) ,forc_hgt_u(i) ,forc_hgt_t(i) ,forc_hgt_q(i) ,& - forc_rhoair(i) ,Fhac(u) ,Fwst(u) ,Fach(u) ,& - Fahe(u) ,Fhah(u) ,vehc(u) ,meta(u) ,& - - ! LAND SURFACE VARIABLES REQUIRED FOR RESTART - z_sno_roof (maxsnl+1:,u) ,z_sno_gimp (maxsnl+1:,u) ,& - z_sno_gper (maxsnl+1:,u) ,z_sno_lake (maxsnl+1:,u) ,& - dz_sno_roof (maxsnl+1:,u) ,dz_sno_gimp (maxsnl+1:,u) ,& - dz_sno_gper (maxsnl+1:,u) ,dz_sno_lake (maxsnl+1:,u) ,& - t_roofsno (maxsnl+1:,u) ,t_gimpsno (maxsnl+1:,u) ,& - t_gpersno (maxsnl+1:,u) ,t_lakesno (maxsnl+1:,u) ,& - wliq_roofsno(maxsnl+1:,u) ,wliq_gimpsno(maxsnl+1:,u) ,& - wliq_gpersno(maxsnl+1:,u) ,wliq_lakesno(maxsnl+1:,u) ,& - wice_roofsno(maxsnl+1:,u) ,wice_gimpsno(maxsnl+1:,u) ,& - wice_gpersno(maxsnl+1:,u) ,wice_lakesno(maxsnl+1:,u) ,& - z_sno (maxsnl+1:,i) ,dz_sno (maxsnl+1:,i) ,& - wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& - t_soisno (maxsnl+1:,i) ,& - smp (1:,i) ,hk (1:,i) ,& - t_wallsun (1:,u) ,t_wallsha (1:,u) ,& - - lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& - green(i) ,tleaf(i) ,ldew(i) ,t_grnd(i) ,& - - sag_roof(u) ,sag_gimp(u) ,sag_gper(u) ,sag_lake(u) ,& - scv_roof(u) ,scv_gimp(u) ,scv_gper(u) ,scv_lake(u) ,& - snowdp_roof(u) ,snowdp_gimp(u) ,snowdp_gper(u) ,snowdp_lake(u) ,& - fsno_roof(u) ,fsno_gimp(u) ,fsno_gper(u) ,fsno_lake(u) ,& - sag(i) ,scv(i) ,snowdp(i) ,fsno(i) ,& - extkd(i) ,alb(1:,1:,i) ,ssun(1:,1:,i) ,ssha(1:,1:,i) ,& - sroof(1:,1:,u) ,swsun(1:,1:,u) ,swsha(1:,1:,u) ,sgimp(1:,1:,u) ,& - sgper(1:,1:,u) ,slake(1:,1:,u) ,lwsun(u) ,lwsha(u) ,& - lgimp(u) ,lgper(u) ,lveg(u) ,fwsun(u) ,& - dfwsun(u) ,t_room(u) ,troof_inner(u) ,twsun_inner(u) ,& - twsha_inner(u) ,t_roommax(u) ,t_roommin(u) ,tafu(u) ,& - - zwt(i) ,wa(i) ,& - t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& - - ! SNICAR snow model related - snw_rds(:,i) ,ssno_lyr(:,:,:,i),& - mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& - mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& + ! SNICAR snow model related + snw_rds(:,i) ,ssno_lyr(:,:,:,i),& + mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& + mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& #if(defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i) ,fevpg_fld(i) ,finfg_fld(i) ,& + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i) ,fevpg_fld(i) ,finfg_fld(i) ,& #endif - ! additional diagnostic variables for output - laisun(i) ,laisha(i) ,rss(i) ,& - rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& - - ! FLUXES - taux(i) ,tauy(i) ,fsena(i) ,fevpa(i) ,& - lfevpa(i) ,fsenl(i) ,fevpl(i) ,etr(i) ,& - fseng(i) ,fevpg(i) ,olrg(i) ,fgrnd(i) ,& - fsen_roof(u) ,fsen_wsun(u) ,fsen_wsha(u) ,fsen_gimp(u) ,& - fsen_gper(u) ,fsen_urbl(u) ,t_roof(u) ,t_wall(u) ,& - lfevp_roof(u) ,lfevp_gimp(u) ,lfevp_gper(u) ,lfevp_urbl(u) ,& - trad(i) ,tref(i) ,&!tmax(i) ,tmin(i) ,& - qref(i) ,rsur(i) ,rnof(i) ,qintr(i) ,& - qinfl(i) ,qdrip(i) ,rst(i) ,assim(i) ,& - respc(i) ,sabvsun(i) ,sabvsha(i) ,sabg(i) ,& - sr(i) ,solvd(i) ,solvi(i) ,solnd(i) ,& - solni(i) ,srvd(i) ,srvi(i) ,srnd(i) ,& - srni(i) ,solvdln(i) ,solviln(i) ,solndln(i) ,& - solniln(i) ,srvdln(i) ,srviln(i) ,srndln(i) ,& - srniln(i) ,qcharge(i) ,xerr(i) ,zerr(i) ,& - - ! TUNABLE modle constants - zlnd ,zsno ,csoilc ,dewmx ,& - wtfact ,capr ,cnfac ,ssi ,& - wimp ,pondmx ,smpmax ,smpmin ,& - trsmx0 ,tcrit ,& - - ! additional variables required by coupling with WRF model - emis(i) ,z0m(i) ,zol(i) ,rib(i) ,& - ustar(i) ,qstar(i) ,tstar(i) ,fm(i) ,& - fh(i) ,fq(i) ,forc_hpbl(i) ) - ENDIF + ! additional diagnostic variables for output + laisun(i) ,laisha(i) ,rss(i) ,& + rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& + + ! FLUXES + taux(i) ,tauy(i) ,fsena(i) ,fevpa(i) ,& + lfevpa(i) ,fsenl(i) ,fevpl(i) ,etr(i) ,& + fseng(i) ,fevpg(i) ,olrg(i) ,fgrnd(i) ,& + fsen_roof(u) ,fsen_wsun(u) ,fsen_wsha(u) ,fsen_gimp(u) ,& + fsen_gper(u) ,fsen_urbl(u) ,t_roof(u) ,t_wall(u) ,& + lfevp_roof(u) ,lfevp_gimp(u) ,lfevp_gper(u) ,lfevp_urbl(u) ,& + trad(i) ,tref(i) ,&!tmax(i) ,tmin(i) ,& + qref(i) ,rsur(i) ,rnof(i) ,qintr(i) ,& + qinfl(i) ,qdrip(i) ,rst(i) ,assim(i) ,& + respc(i) ,sabvsun(i) ,sabvsha(i) ,sabg(i) ,& + sr(i) ,solvd(i) ,solvi(i) ,solnd(i) ,& + solni(i) ,srvd(i) ,srvi(i) ,srnd(i) ,& + srni(i) ,solvdln(i) ,solviln(i) ,solndln(i) ,& + solniln(i) ,srvdln(i) ,srviln(i) ,srndln(i) ,& + srniln(i) ,qcharge(i) ,xerr(i) ,zerr(i) ,& + + ! TUNABLE modle constants + zlnd ,zsno ,csoilc ,dewmx ,& + wtfact ,capr ,cnfac ,ssi ,& + wimp ,pondmx ,smpmax ,smpmin ,& + trsmx0 ,tcrit ,& + + ! additional variables required by coupling with WRF model + emis(i) ,z0m(i) ,zol(i) ,rib(i) ,& + ustar(i) ,qstar(i) ,tstar(i) ,fm(i) ,& + fh(i) ,fq(i) ,forc_hpbl(i) ) + ENDIF #endif - ENDDO + ENDDO #ifdef OPENMP !$OMP END PARALLEL DO #endif diff --git a/main/CoLMMAIN.F90 b/main/CoLMMAIN.F90 index 90af8cce..f96b1de5 100644 --- a/main/CoLMMAIN.F90 +++ b/main/CoLMMAIN.F90 @@ -607,9 +607,9 @@ SUBROUTINE CoLMMAIN ( & zi_soisno(0)=0. IF (snl < 0) THEN - DO j = -1, snl, -1 - zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) - ENDDO + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO ENDIF DO j = 1,nl_soil zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) @@ -870,9 +870,9 @@ SUBROUTINE CoLMMAIN ( & ENDIF #if(defined CaMa_Flood) IF (LWINFILT) THEN - IF (patchtype == 0) THEN - endwb=endwb - qinfl_fld*deltim - ENDIF + IF (patchtype == 0) THEN + endwb=endwb - qinfl_fld*deltim + ENDIF ENDIF #endif @@ -922,9 +922,9 @@ SUBROUTINE CoLMMAIN ( & zi_soisno(0)=0. IF (snl < 0) THEN - DO j = -1, snl, -1 - zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) - ENDDO + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO ENDIF DO j = 1,nl_soil zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) @@ -1301,11 +1301,11 @@ SUBROUTINE CoLMMAIN ( & #if(defined CaMa_Flood) IF (LWEVAP) THEN IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05).and.patchtype == 0)THEN - CALL get_fldevp (forc_hgt_u,forc_hgt_t,forc_hgt_q,& - forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf,t_grnd,& - forc_hpbl, & - taux_fld,tauy_fld,fseng_fld,fevpg_fld,tref_fld,qref_fld,& - z0m_fld,zol_fld,rib_fld,ustar_fld,qstar_fld,tstar_fld,fm_fld,fh_fld,fq_fld) + CALL get_fldevp (forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf,t_grnd,& + forc_hpbl, & + taux_fld,tauy_fld,fseng_fld,fevpg_fld,tref_fld,qref_fld,& + z0m_fld,zol_fld,rib_fld,ustar_fld,qstar_fld,tstar_fld,fm_fld,fh_fld,fq_fld) IF (fevpg_fld<0.0) fevpg_fld=0.0d0 IF ((flddepth-deltim*fevpg_fld .gt. 0.0) .and. (fevpg_fld.gt.0.0)) THEN flddepth=flddepth-deltim*fevpg_fld @@ -1440,14 +1440,14 @@ SUBROUTINE CoLMMAIN ( & ! we supposed CALL it every time-step, because ! other vegeation related parameters are needed to create IF (doalb) THEN - CALL albland (ipatch, patchtype,deltim,& - soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& - chil,rho,tau,fveg,green,lai,sai,coszen,& - wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& - snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& - mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& - mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) + CALL albland (ipatch, patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) ENDIF ELSE !OCEAN sag = 0.0 diff --git a/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 b/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 index 8adc37b7..46990d3e 100644 --- a/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 +++ b/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 @@ -432,178 +432,178 @@ SUBROUTINE SAVE_LulccTimeVariables IMPLICIT NONE IF (p_is_worker) THEN - z_sno_ = z_sno - dz_sno_ = dz_sno - t_soisno_ = t_soisno - wliq_soisno_ = wliq_soisno - wice_soisno_ = wice_soisno - smp_ = smp - hk_ = hk - t_grnd_ = t_grnd - tleaf_ = tleaf - ldew_ = ldew - ldew_rain_ = ldew_rain - ldew_snow_ = ldew_snow - sag_ = sag - scv_ = scv - snowdp_ = snowdp - fsno_ = fsno - sigf_ = sigf - zwt_ = zwt - wa_ = wa - wdsrf_ = wdsrf - rss_ = rss - - t_lake_ = t_lake - lake_icefrac_ = lake_icefrac - savedtke1_ = savedtke1 + z_sno_ = z_sno + dz_sno_ = dz_sno + t_soisno_ = t_soisno + wliq_soisno_ = wliq_soisno + wice_soisno_ = wice_soisno + smp_ = smp + hk_ = hk + t_grnd_ = t_grnd + tleaf_ = tleaf + ldew_ = ldew + ldew_rain_ = ldew_rain + ldew_snow_ = ldew_snow + sag_ = sag + scv_ = scv + snowdp_ = snowdp + fsno_ = fsno + sigf_ = sigf + zwt_ = zwt + wa_ = wa + wdsrf_ = wdsrf + rss_ = rss + + t_lake_ = t_lake + lake_icefrac_ = lake_icefrac + savedtke1_ = savedtke1 IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_ = vegwp - gs0sun_ = gs0sun - gs0sha_ = gs0sha + vegwp_ = vegwp + gs0sun_ = gs0sun + gs0sha_ = gs0sha ENDIF IF(DEF_USE_OZONESTRESS)THEN - lai_old_ = lai_old - o3uptakesun_ = o3uptakesun - o3uptakesha_ = o3uptakesha + lai_old_ = lai_old + o3uptakesun_ = o3uptakesun + o3uptakesha_ = o3uptakesha ENDIF - snw_rds_ = snw_rds - mss_bcpho_ = mss_bcpho - mss_bcphi_ = mss_bcphi - mss_ocpho_ = mss_ocpho - mss_ocphi_ = mss_ocphi - mss_dst1_ = mss_dst1 - mss_dst2_ = mss_dst2 - mss_dst3_ = mss_dst3 - mss_dst4_ = mss_dst4 - ssno_lyr_ = ssno_lyr - - trad_ = trad - tref_ = tref - qref_ = qref - rst_ = rst - emis_ = emis - z0m_ = z0m - displa_ = displa - zol_ = zol - rib_ = rib - ustar_ = ustar - qstar_ = qstar - tstar_ = tstar - fm_ = fm - fh_ = fh - fq_ = fq + snw_rds_ = snw_rds + mss_bcpho_ = mss_bcpho + mss_bcphi_ = mss_bcphi + mss_ocpho_ = mss_ocpho + mss_ocphi_ = mss_ocphi + mss_dst1_ = mss_dst1 + mss_dst2_ = mss_dst2 + mss_dst3_ = mss_dst3 + mss_dst4_ = mss_dst4 + ssno_lyr_ = ssno_lyr + + trad_ = trad + tref_ = tref + qref_ = qref + rst_ = rst + emis_ = emis + z0m_ = z0m + displa_ = displa + zol_ = zol + rib_ = rib + ustar_ = ustar + qstar_ = qstar + tstar_ = tstar + fm_ = fm + fh_ = fh + fq_ = fq IF (DEF_USE_IRRIGATION) THEN - sum_irrig_ = sum_irrig - sum_irrig_count_ = sum_irrig_count + sum_irrig_ = sum_irrig + sum_irrig_count_ = sum_irrig_count ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - tleaf_p_ = tleaf_p - ldew_p_ = ldew_p - ldew_rain_p_ = ldew_rain_p - ldew_snow_p_ = ldew_snow_p - sigf_p_ = sigf_p - - tref_p_ = tref_p - qref_p_ = qref_p - rst_p_ = rst_p - z0m_p_ = z0m_p + tleaf_p_ = tleaf_p + ldew_p_ = ldew_p + ldew_rain_p_ = ldew_rain_p + ldew_snow_p_ = ldew_snow_p + sigf_p_ = sigf_p + + tref_p_ = tref_p + qref_p_ = qref_p + rst_p_ = rst_p + z0m_p_ = z0m_p IF(DEF_USE_PLANTHYDRAULICS)THEN - ! Plant Hydraulic variables - vegwp_p_ = vegwp_p - gs0sun_p_ = gs0sun_p - gs0sha_p_ = gs0sha_p - ! end plant hydraulic variables + ! Plant Hydraulic variables + vegwp_p_ = vegwp_p + gs0sun_p_ = gs0sun_p + gs0sha_p_ = gs0sha_p + ! end plant hydraulic variables ENDIF IF(DEF_USE_OZONESTRESS)THEN - ! Ozone Stress Variables - lai_old_p_ = lai_old_p - o3uptakesun_p_ = o3uptakesun_p - o3uptakesha_p_ = o3uptakesha_p - ! End allocate Ozone Stress Variables + ! Ozone Stress Variables + lai_old_p_ = lai_old_p + o3uptakesun_p_ = o3uptakesun_p + o3uptakesha_p_ = o3uptakesha_p + ! End allocate Ozone Stress Variables ENDIF #endif #ifdef URBAN_MODEL - fwsun_ = fwsun - dfwsun_ = dfwsun - - sroof_ = sroof - swsun_ = swsun - swsha_ = swsha - sgimp_ = sgimp - sgper_ = sgper - slake_ = slake - - lwsun_ = lwsun - lwsha_ = lwsha - lgimp_ = lgimp - lgper_ = lgper - lveg_ = lveg - - z_sno_roof_ = z_sno_roof - z_sno_gimp_ = z_sno_gimp - z_sno_gper_ = z_sno_gper - z_sno_lake_ = z_sno_lake - - dz_sno_roof_ = dz_sno_roof - dz_sno_gimp_ = dz_sno_gimp - dz_sno_gper_ = dz_sno_gper - dz_sno_lake_ = dz_sno_lake - - t_roofsno_ = t_roofsno - t_wallsun_ = t_wallsun - t_wallsha_ = t_wallsha - t_gimpsno_ = t_gimpsno - t_gpersno_ = t_gpersno - t_lakesno_ = t_lakesno - - troof_inner_ = troof_inner - twsun_inner_ = twsun_inner - twsha_inner_ = twsha_inner - - wliq_roofsno_ = wliq_roofsno - wice_roofsno_ = wice_roofsno - wliq_gimpsno_ = wliq_gimpsno - wice_gimpsno_ = wice_gimpsno - wliq_gpersno_ = wliq_gpersno - wice_gpersno_ = wice_gpersno - wliq_lakesno_ = wliq_lakesno - wice_lakesno_ = wice_lakesno - - sag_roof_ = sag_roof - sag_gimp_ = sag_gimp - sag_gper_ = sag_gper - sag_lake_ = sag_lake - scv_roof_ = scv_roof - scv_gimp_ = scv_gimp - scv_gper_ = scv_gper - scv_lake_ = scv_lake - fsno_roof_ = fsno_roof - fsno_gimp_ = fsno_gimp - fsno_gper_ = fsno_gper - fsno_lake_ = fsno_lake - snowdp_roof_ = snowdp_roof - snowdp_gimp_ = snowdp_gimp - snowdp_gper_ = snowdp_gper - snowdp_lake_ = snowdp_lake - - Fhac_ = Fhac - Fwst_ = Fwst - Fach_ = Fach - Fahe_ = Fahe - Fhah_ = Fhah - vehc_ = vehc - meta_ = meta - t_room_ = t_room - t_roof_ = t_roof - t_wall_ = t_wall - tafu_ = tafu - urb_green_ = urb_green + fwsun_ = fwsun + dfwsun_ = dfwsun + + sroof_ = sroof + swsun_ = swsun + swsha_ = swsha + sgimp_ = sgimp + sgper_ = sgper + slake_ = slake + + lwsun_ = lwsun + lwsha_ = lwsha + lgimp_ = lgimp + lgper_ = lgper + lveg_ = lveg + + z_sno_roof_ = z_sno_roof + z_sno_gimp_ = z_sno_gimp + z_sno_gper_ = z_sno_gper + z_sno_lake_ = z_sno_lake + + dz_sno_roof_ = dz_sno_roof + dz_sno_gimp_ = dz_sno_gimp + dz_sno_gper_ = dz_sno_gper + dz_sno_lake_ = dz_sno_lake + + t_roofsno_ = t_roofsno + t_wallsun_ = t_wallsun + t_wallsha_ = t_wallsha + t_gimpsno_ = t_gimpsno + t_gpersno_ = t_gpersno + t_lakesno_ = t_lakesno + + troof_inner_ = troof_inner + twsun_inner_ = twsun_inner + twsha_inner_ = twsha_inner + + wliq_roofsno_ = wliq_roofsno + wice_roofsno_ = wice_roofsno + wliq_gimpsno_ = wliq_gimpsno + wice_gimpsno_ = wice_gimpsno + wliq_gpersno_ = wliq_gpersno + wice_gpersno_ = wice_gpersno + wliq_lakesno_ = wliq_lakesno + wice_lakesno_ = wice_lakesno + + sag_roof_ = sag_roof + sag_gimp_ = sag_gimp + sag_gper_ = sag_gper + sag_lake_ = sag_lake + scv_roof_ = scv_roof + scv_gimp_ = scv_gimp + scv_gper_ = scv_gper + scv_lake_ = scv_lake + fsno_roof_ = fsno_roof + fsno_gimp_ = fsno_gimp + fsno_gper_ = fsno_gper + fsno_lake_ = fsno_lake + snowdp_roof_ = snowdp_roof + snowdp_gimp_ = snowdp_gimp + snowdp_gper_ = snowdp_gper + snowdp_lake_ = snowdp_lake + + Fhac_ = Fhac + Fwst_ = Fwst + Fach_ = Fach + Fahe_ = Fahe + Fhah_ = Fhah + vehc_ = vehc + meta_ = meta + t_room_ = t_room + t_roof_ = t_roof + t_wall_ = t_wall + tafu_ = tafu + urb_green_ = urb_green #endif ENDIF diff --git a/main/MOD_3DCanopyRadiation.F90 b/main/MOD_3DCanopyRadiation.F90 index c39a7b07..1ff37571 100644 --- a/main/MOD_3DCanopyRadiation.F90 +++ b/main/MOD_3DCanopyRadiation.F90 @@ -790,9 +790,9 @@ SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & print *, fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1 ENDIF - !==================================================== - ! Calculate individule PFT absorption - !==================================================== + !==================================================== + ! Calculate individule PFT absorption + !==================================================== sum_fabd=D0 sum_fabi=D0 diff --git a/main/MOD_Aerosol.F90 b/main/MOD_Aerosol.F90 index 464b17ea..b2c3ad95 100644 --- a/main/MOD_Aerosol.F90 +++ b/main/MOD_Aerosol.F90 @@ -96,69 +96,69 @@ SUBROUTINE AerosolMasses( dtime ,snl ,do_capsnow ,& DO j = maxsnl+1, 0 - ! layer mass of snow: - snowmass = h2osno_ice(j) + h2osno_liq(j) - - IF (.not. use_extrasnowlayers) THEN - ! Correct the top layer aerosol mass to account for snow capping. - ! This approach conserves the aerosol mass concentration - ! (but not the aerosol amss) when snow-capping is invoked - - IF (j == snl+1) THEN - IF (do_capsnow) THEN - - snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice*dtime)) - - mss_bcpho(j) = mss_bcpho(j)*snowcap_scl_fct - mss_bcphi(j) = mss_bcphi(j)*snowcap_scl_fct - mss_ocpho(j) = mss_ocpho(j)*snowcap_scl_fct - mss_ocphi(j) = mss_ocphi(j)*snowcap_scl_fct - - mss_dst1(j) = mss_dst1(j)*snowcap_scl_fct - mss_dst2(j) = mss_dst2(j)*snowcap_scl_fct - mss_dst3(j) = mss_dst3(j)*snowcap_scl_fct - mss_dst4(j) = mss_dst4(j)*snowcap_scl_fct - ENDIF - ENDIF - ENDIF - - IF (j >= snl+1) THEN - - mss_cnc_bcphi(j) = mss_bcphi(j) / snowmass - mss_cnc_bcpho(j) = mss_bcpho(j) / snowmass - - mss_cnc_ocphi(j) = mss_ocphi(j) / snowmass - mss_cnc_ocpho(j) = mss_ocpho(j) / snowmass - - mss_cnc_dst1(j) = mss_dst1(j) / snowmass - mss_cnc_dst2(j) = mss_dst2(j) / snowmass - mss_cnc_dst3(j) = mss_dst3(j) / snowmass - mss_cnc_dst4(j) = mss_dst4(j) / snowmass - - ELSE - ! 01/10/2023, yuan: set empty snow layers to snw_rds_min - !snw_rds(j) = 0._r8 - snw_rds(j) = snw_rds_min - - mss_bcpho(j) = 0._r8 - mss_bcphi(j) = 0._r8 - mss_cnc_bcphi(j) = 0._r8 - mss_cnc_bcpho(j) = 0._r8 - - mss_ocpho(j) = 0._r8 - mss_ocphi(j) = 0._r8 - mss_cnc_ocphi(j) = 0._r8 - mss_cnc_ocpho(j) = 0._r8 - - mss_dst1(j) = 0._r8 - mss_dst2(j) = 0._r8 - mss_dst3(j) = 0._r8 - mss_dst4(j) = 0._r8 - mss_cnc_dst1(j) = 0._r8 - mss_cnc_dst2(j) = 0._r8 - mss_cnc_dst3(j) = 0._r8 - mss_cnc_dst4(j) = 0._r8 - ENDIF + ! layer mass of snow: + snowmass = h2osno_ice(j) + h2osno_liq(j) + + IF (.not. use_extrasnowlayers) THEN + ! Correct the top layer aerosol mass to account for snow capping. + ! This approach conserves the aerosol mass concentration + ! (but not the aerosol amss) when snow-capping is invoked + + IF (j == snl+1) THEN + IF (do_capsnow) THEN + + snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice*dtime)) + + mss_bcpho(j) = mss_bcpho(j)*snowcap_scl_fct + mss_bcphi(j) = mss_bcphi(j)*snowcap_scl_fct + mss_ocpho(j) = mss_ocpho(j)*snowcap_scl_fct + mss_ocphi(j) = mss_ocphi(j)*snowcap_scl_fct + + mss_dst1(j) = mss_dst1(j)*snowcap_scl_fct + mss_dst2(j) = mss_dst2(j)*snowcap_scl_fct + mss_dst3(j) = mss_dst3(j)*snowcap_scl_fct + mss_dst4(j) = mss_dst4(j)*snowcap_scl_fct + ENDIF + ENDIF + ENDIF + + IF (j >= snl+1) THEN + + mss_cnc_bcphi(j) = mss_bcphi(j) / snowmass + mss_cnc_bcpho(j) = mss_bcpho(j) / snowmass + + mss_cnc_ocphi(j) = mss_ocphi(j) / snowmass + mss_cnc_ocpho(j) = mss_ocpho(j) / snowmass + + mss_cnc_dst1(j) = mss_dst1(j) / snowmass + mss_cnc_dst2(j) = mss_dst2(j) / snowmass + mss_cnc_dst3(j) = mss_dst3(j) / snowmass + mss_cnc_dst4(j) = mss_dst4(j) / snowmass + + ELSE + ! 01/10/2023, yuan: set empty snow layers to snw_rds_min + !snw_rds(j) = 0._r8 + snw_rds(j) = snw_rds_min + + mss_bcpho(j) = 0._r8 + mss_bcphi(j) = 0._r8 + mss_cnc_bcphi(j) = 0._r8 + mss_cnc_bcpho(j) = 0._r8 + + mss_ocpho(j) = 0._r8 + mss_ocphi(j) = 0._r8 + mss_cnc_ocphi(j) = 0._r8 + mss_cnc_ocpho(j) = 0._r8 + + mss_dst1(j) = 0._r8 + mss_dst2(j) = 0._r8 + mss_dst3(j) = 0._r8 + mss_dst4(j) = 0._r8 + mss_cnc_dst1(j) = 0._r8 + mss_cnc_dst2(j) = 0._r8 + mss_cnc_dst3(j) = 0._r8 + mss_cnc_dst4(j) = 0._r8 + ENDIF ENDDO END SUBROUTINE AerosolMasses diff --git a/main/MOD_Albedo.F90 b/main/MOD_Albedo.F90 index 1cb0cb8c..20a9cb1f 100644 --- a/main/MOD_Albedo.F90 +++ b/main/MOD_Albedo.F90 @@ -1469,67 +1469,67 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& IF (use_snicar_frc) THEN ! 1. PURE SNOW ALBEDO CALCULATIONS - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsnd_pur(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsnd_pur(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsni_pur(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsni_pur(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad ! 2. BC input array: ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] @@ -1681,109 +1681,19 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& ENDIF ! END IF (DO_SNO_OC) ! 4. DUST FORCING CALCULATIONS - ! DUST input array: - ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] - mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) - mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) - - IF (DO_SNO_OC) THEN - mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) - mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) - ENDIF - - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsnd_dst(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsnd_dst(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsni_dst(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsni_dst(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - ENDIF !END IF use_snicar_frc - + ! DUST input array: + ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] + mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) - ! -------------------------------------------- - ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: - ! -------------------------------------------- - ! Set aerosol input arrays - ! feedback input arrays have been zeroed - ! set soot and dust aerosol concentrations: - IF (DO_SNO_AER) THEN - mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) - mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) - - ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: - ! 1) Knowledge of their optical properties is primitive - ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, - ! it has a negligible darkening effect. - IF (DO_SNO_OC) THEN - mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) - mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) - ENDIF - - mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) - mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) - mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) - mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) - ENDIF + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + ENDIF - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1792,12 +1702,12 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& h2osno_liq(:), & h2osno_ice(:), & snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & + mss_cnc_aer_in_frc_dst(:, :), & albsfc(:), & - albsnd(:), & - flx_absd_snw(:, :) ) - ELSE - CALL SNICAR_RT (flg_snw_ice, & + albsnd_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1806,15 +1716,15 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& h2osno_liq(:), & h2osno_ice(:), & snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & + mss_cnc_aer_in_frc_dst(:, :), & albsfc(:), & - albsnd(:), & - flx_absd_snw(:, :) ) - ENDIF ! END IF use_snicar_ad + albsnd_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1823,12 +1733,12 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& h2osno_liq(:), & h2osno_ice(:), & snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & + mss_cnc_aer_in_frc_dst(:, :), & albsfc(:), & - albsni(:), & - flx_absi_snw(:, :) ) - ELSE - CALL SNICAR_RT (flg_snw_ice, & + albsni_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1837,10 +1747,100 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& h2osno_liq(:), & h2osno_ice(:), & snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & + mss_cnc_aer_in_frc_dst(:, :), & albsfc(:), & - albsni(:), & - flx_absi_snw(:, :) ) + albsni_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ENDIF !END IF use_snicar_frc + + + ! -------------------------------------------- + ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: + ! -------------------------------------------- + ! Set aerosol input arrays + ! feedback input arrays have been zeroed + ! set soot and dust aerosol concentrations: + IF (DO_SNO_AER) THEN + mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) + + ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: + ! 1) Knowledge of their optical properties is primitive + ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, + ! it has a negligible darkening effect. + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) + ENDIF + + mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) ENDIF ! END IF use_snicar_ad @@ -1979,45 +1979,45 @@ SUBROUTINE albocean (oro, scv, coszrs, alb) IF(coszrs<=0.0) RETURN IF(nint(oro)==2)THEN - alb(1,1) = asices - alb(2,1) = asicel - alb(1,2) = alb(1,1) - alb(2,2) = alb(2,1) - sasdif = asnows - saldif = asnowl - - IF(scv>0.)THEN - IF (coszrs<0.5) THEN - ! zenith angle regime 1 ( coszrs < 0.5 ). - ! set direct snow albedos (limit to 0.98 max) - sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) - saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) - ELSE - ! zenith angle regime 2 ( coszrs >= 0.5 ) - sasdir = asnows - saldir = asnowl - ENDIF - - ! compute both diffuse and direct total albedos - snwhgt = 20.*scv / 1000. - rghsnw = 0.25 - frsnow = snwhgt/(rghsnw+snwhgt) - alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow - alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow - alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow - alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow - ENDIF + alb(1,1) = asices + alb(2,1) = asicel + alb(1,2) = alb(1,1) + alb(2,2) = alb(2,1) + sasdif = asnows + saldif = asnowl + + IF(scv>0.)THEN + IF (coszrs<0.5) THEN + ! zenith angle regime 1 ( coszrs < 0.5 ). + ! set direct snow albedos (limit to 0.98 max) + sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) + saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) + ELSE + ! zenith angle regime 2 ( coszrs >= 0.5 ) + sasdir = asnows + saldir = asnowl + ENDIF + + ! compute both diffuse and direct total albedos + snwhgt = 20.*scv / 1000. + rghsnw = 0.25 + frsnow = snwhgt/(rghsnw+snwhgt) + alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow + alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow + alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow + alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow + ENDIF ENDIF ! ice-free ocean albedos function of solar zenith angle only, and ! independent of spectral interval: IF(nint(oro)==0)THEN - alb(2,1) = .026/(coszrs**1.7+.065) & - + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) - alb(1,1) = alb(2,1) - alb(1,2) = 0.06 - alb(2,2) = 0.06 + alb(2,1) = .026/(coszrs**1.7+.065) & + + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) + alb(1,1) = alb(2,1) + alb(1,2) = 0.06 + alb(2,2) = 0.06 ENDIF END SUBROUTINE albocean diff --git a/main/MOD_AssimStomataConductance.F90 b/main/MOD_AssimStomataConductance.F90 index 12ca513c..82e8f277 100644 --- a/main/MOD_AssimStomataConductance.F90 +++ b/main/MOD_AssimStomataConductance.F90 @@ -189,14 +189,14 @@ SUBROUTINE stomata (vmax25,effcon,slti,hlti,shti, & range = pco2m * ( 1. - 1.6/gradm ) - gammas DO ic = 1, iterationtotal ! loop for total iteration number - pco2y(ic) = 0. - eyy(ic) = 0. + pco2y(ic) = 0. + eyy(ic) = 0. ENDDO ITERATION_LOOP: DO ic = 1, iterationtotal - CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) - pco2i = pco2y(ic) + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) !----------------------------------------------------------------------- ! NET ASSIMILATION @@ -210,19 +210,19 @@ SUBROUTINE stomata (vmax25,effcon,slti,hlti,shti, & ! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 !----------------------------------------------------------------------- - atheta = 0.877 - btheta = 0.95 + atheta = 0.877 + btheta = 0.95 - omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 - ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 - oms = omss * c3 + omss*pco2i * c4 + omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 + oms = omss * c3 + omss*pco2i * c4 - sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) - omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) - sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) - assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) - assimn= ( assim - respc) ! mol m-2 s-1 + assimn= ( assim - respc) ! mol m-2 s-1 !----------------------------------------------------------------------- ! STOMATAL CONDUCTANCE @@ -268,45 +268,45 @@ SUBROUTINE stomata (vmax25,effcon,slti,hlti,shti, & ! !----------------------------------------------------------------------- - co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 - co2st = min( co2s, co2a ) - co2st = max( co2st,1.e-5 ) + co2st = min( co2s, co2a ) + co2st = max( co2st,1.e-5 ) - assmt = max( 1.e-12, assimn ) - IF(DEF_USE_MEDLYNST)THEN - vpd = amax1((ei - ea),50._r8) * 1.e-3 ! in kpa - acp = 1.6*assmt/co2st ! in mol m-2 s-1 - aquad = 1._r8 - bquad = -2*(g0*1.e-6 + acp) - (g1*acp)**2/(gbh2o*vpd) ! in mol m-2 s-1 - cquad = (g0*1.e-6)**2 + (2*g0*1.e-6+acp*(1-g1**2)/vpd)*acp ! in (mol m-2 s-1)**2 + assmt = max( 1.e-12, assimn ) + IF(DEF_USE_MEDLYNST)THEN + vpd = amax1((ei - ea),50._r8) * 1.e-3 ! in kpa + acp = 1.6*assmt/co2st ! in mol m-2 s-1 + aquad = 1._r8 + bquad = -2*(g0*1.e-6 + acp) - (g1*acp)**2/(gbh2o*vpd) ! in mol m-2 s-1 + cquad = (g0*1.e-6)**2 + (2*g0*1.e-6+acp*(1-g1**2)/vpd)*acp ! in (mol m-2 s-1)**2 - sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) - gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) - ELSE - hcdma = ei*co2st / ( gradm*assmt ) + ELSE + hcdma = ei*co2st / ( gradm*assmt ) - aquad = hcdma - bquad = gbh2o*hcdma - ei - bintc*hcdma - cquad = -gbh2o*( ea + hcdma*bintc ) + aquad = hcdma + bquad = gbh2o*hcdma - ei - bintc*hcdma + cquad = -gbh2o*( ea + hcdma*bintc ) - sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) - gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) - es = ( gsh2o-bintc ) * hcdma ! pa - es = min( es, ei ) - es = max( es, 1.e-2) + es = ( gsh2o-bintc ) * hcdma ! pa + es = min( es, ei ) + es = max( es, 1.e-2) - gsh2o = es/hcdma + bintc ! mol m-2 s-1 - ENDIF + gsh2o = es/hcdma + bintc ! mol m-2 s-1 + ENDIF - pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa - eyy(ic) = pco2i - pco2in ! pa + pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa + eyy(ic) = pco2i - pco2in ! pa !----------------------------------------------------------------------- - IF( abs(eyy(ic)) .lt. 0.1 ) EXIT + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT ENDDO ITERATION_LOOP @@ -636,8 +636,8 @@ SUBROUTINE update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2 ITERATION_LOOP_UPDATE: DO ic = 1, iterationtotal - CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) - pco2i = pco2y(ic) + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) !----------------------------------------------------------------------- ! NET ASSIMILATION @@ -651,19 +651,19 @@ SUBROUTINE update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2 ! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 !----------------------------------------------------------------------- - atheta = 0.877 - btheta = 0.95 + atheta = 0.877 + btheta = 0.95 - omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 - ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 - oms = omss * c3 + omss*pco2i * c4 + omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 + oms = omss * c3 + omss*pco2i * c4 - sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) - omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) - sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) - assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) - assimn= ( assim - respc) ! mol m-2 s-1 + assimn= ( assim - respc) ! mol m-2 s-1 !----------------------------------------------------------------------- ! STOMATAL CONDUCTANCE @@ -709,15 +709,15 @@ SUBROUTINE update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2 ! !----------------------------------------------------------------------- - co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 - pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa + pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa - eyy(ic) = pco2i - pco2in ! pa + eyy(ic) = pco2i - pco2in ! pa !----------------------------------------------------------------------- - IF( abs(eyy(ic)) .lt. 0.1 ) EXIT + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT ENDDO ITERATION_LOOP_UPDATE diff --git a/main/MOD_CropReadin.F90 b/main/MOD_CropReadin.F90 index fca1e5d5..ab735bd9 100644 --- a/main/MOD_CropReadin.F90 +++ b/main/MOD_CropReadin.F90 @@ -136,15 +136,15 @@ SUBROUTINE CROP_readin () CALL mg2pft_crop%map_aweighted (f_xy_crop, plantdate_tmp) - if (p_is_worker) THEN - do ipft = 1, numpft + IF (p_is_worker) THEN + DO ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft)THEN plantdate_p(ipft) = plantdate_tmp(ipft) - if(plantdate_p(ipft) <= 0._r8) then + IF(plantdate_p(ipft) <= 0._r8) THEN plantdate_p(ipft) = -99999999._r8 - END if - endif - END do + ENDIF + ENDIF + ENDDO ENDIF ENDDO @@ -165,15 +165,15 @@ SUBROUTINE CROP_readin () CALL mg2pft_crop%map_aweighted (f_xy_crop, fertnitro_tmp) - if (p_is_worker) then - do ipft = 1, numpft + IF (p_is_worker) THEN + DO ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft)THEN fertnitro_p(ipft) = fertnitro_tmp(ipft) - if(fertnitro_p(ipft) <= 0._r8) then + IF(fertnitro_p(ipft) <= 0._r8) THEN fertnitro_p(ipft) = 0._r8 - END if - endif - END do + ENDIF + ENDIF + ENDDO ENDIF ENDDO @@ -210,16 +210,16 @@ SUBROUTINE CROP_readin () CALL mg2pft_irrig%map_max_frenquency_2d (f_xy_irrig, irrig_method_tmp) - if (p_is_worker) then - do ipft = 1, numpft + IF (p_is_worker) THEN + DO ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft + 14)THEN irrig_method_p(ipft) = irrig_method_tmp(ipft) - if(irrig_method_p(ipft) < 0) then + IF(irrig_method_p(ipft) < 0) THEN irrig_method_p(ipft) = -99999999 - END if - endif - END do + ENDIF + ENDIF + ENDDO ENDIF ENDDO diff --git a/main/MOD_Eroot.F90 b/main/MOD_Eroot.F90 index f45a6506..3ac1d974 100644 --- a/main/MOD_Eroot.F90 +++ b/main/MOD_Eroot.F90 @@ -85,24 +85,24 @@ SUBROUTINE eroot (nl_soil,trsmx0,porsl, & roota = 1.e-10 ! must be non-zero to begin DO i = 1, nl_soil - IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN - smpmax = -1.5e5 - s_node = max(wliq_soisno(i)/(1000.*dz_soisno(i)*porsl(i)),0.001) - s_node = min(1., s_node) + IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN + smpmax = -1.5e5 + s_node = max(wliq_soisno(i)/(1000.*dz_soisno(i)*porsl(i)),0.001) + s_node = min(1., s_node) #ifdef Campbell_SOIL_MODEL - smp_node = max(smpmax, psi0(i)*s_node**(-bsw(i))) + smp_node = max(smpmax, psi0(i)*s_node**(-bsw(i))) #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - smp_node = soil_psi_from_vliq ( s_node*(porsl(i)-theta_r(i)) + theta_r(i), & - porsl(i), theta_r(i), psi0(i), & - 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) - smp_node = max(smpmax, smp_node) + smp_node = soil_psi_from_vliq ( s_node*(porsl(i)-theta_r(i)) + theta_r(i), & + porsl(i), theta_r(i), psi0(i), & + 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + smp_node = max(smpmax, smp_node) #endif - rresis(i) =(1.-smp_node/smpmax)/(1.-psi0(i)/smpmax) - rootr(i) = rootfr(i)*rresis(i) - roota = roota + rootr(i) + rresis(i) =(1.-smp_node/smpmax)/(1.-psi0(i)/smpmax) + rootr(i) = rootfr(i)*rresis(i) + roota = roota + rootr(i) ELSE - rootr(i) = 0. + rootr(i) = 0. ENDIF ENDDO diff --git a/main/MOD_Forcing.F90 b/main/MOD_Forcing.F90 index c1ea0bb5..6b851ac2 100644 --- a/main/MOD_Forcing.F90 +++ b/main/MOD_Forcing.F90 @@ -641,7 +641,7 @@ SUBROUTINE read_forcing (idate, dir_forcing) CALL check_vector_data ('Forcing solld [W/m2] ', forc_solld) CALL check_vector_data ('Forcing frl [W/m2] ', forc_frl ) IF (DEF_USE_CBL_HEIGHT) THEN - CALL check_vector_data ('Forcing hpbl ', forc_hpbl ) + CALL check_vector_data ('Forcing hpbl ', forc_hpbl ) ENDIF #ifdef USEMPI @@ -964,22 +964,22 @@ SUBROUTINE metread_time (dir_forcing, ststamp, etstamp, deltime) END SUBROUTINE metread_time - ! ------------------------------------------------------------ - ! - ! !DESCRIPTION: - ! set the lower boundary time stamp and record information, - ! a KEY FUNCTION of this MODULE - ! - ! - for time stamp, set it regularly as the model time step. - ! - for record information, account for: - ! o year alternation - ! o month alternation - ! o leap year - ! o required dada just beyond the first record - ! - ! REVISIONS: - ! Hua Yuan, 04/2014: initial code - ! ------------------------------------------------------------ +! ------------------------------------------------------------ +! +! !DESCRIPTION: +! set the lower boundary time stamp and record information, +! a KEY FUNCTION of this MODULE +! +! - for time stamp, set it regularly as the model time step. +! - for record information, account for: +! o year alternation +! o month alternation +! o leap year +! o required dada just beyond the first record +! +! REVISIONS: +! Hua Yuan, 04/2014: initial code +! ------------------------------------------------------------ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) IMPLICIT NONE @@ -1199,15 +1199,15 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) END SUBROUTINE setstampLB - ! ------------------------------------------------------------ - ! - ! !DESCRIPTION: - ! set the upper boundary time stamp and record information, - ! a KEY FUNCTION of this MODULE - ! - ! REVISIONS: - ! Hua Yuan, 04/2014: initial code - ! ------------------------------------------------------------ +! ------------------------------------------------------------ +! +! !DESCRIPTION: +! set the upper boundary time stamp and record information, +! a KEY FUNCTION of this MODULE +! +! REVISIONS: +! Hua Yuan, 04/2014: initial code +! ------------------------------------------------------------ SUBROUTINE setstampUB(var_i, year, month, mday, time_i) IMPLICIT NONE @@ -1359,13 +1359,13 @@ SUBROUTINE setstampUB(var_i, year, month, mday, time_i) END SUBROUTINE setstampUB - ! ------------------------------------------------------------ - ! !DESCRIPTION: - ! calculate time average coszen value bwteeen [LB, UB] - ! - ! REVISIONS: - ! 04/2014, yuan: this method is adapted from CLM - ! ------------------------------------------------------------ +! ------------------------------------------------------------ +! !DESCRIPTION: +! calculate time average coszen value bwteeen [LB, UB] +! +! REVISIONS: +! 04/2014, yuan: this method is adapted from CLM +! ------------------------------------------------------------ SUBROUTINE calavgcos(idate) USE MOD_Block diff --git a/main/MOD_FrictionVelocity.F90 b/main/MOD_FrictionVelocity.F90 index 33579d40..4ebc4220 100644 --- a/main/MOD_FrictionVelocity.F90 +++ b/main/MOD_FrictionVelocity.F90 @@ -73,18 +73,18 @@ SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& zeta=zldis/obu zetam=1.574 IF(zeta < -zetam)THEN ! zeta < -1 - fm = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) - ustar = vonkar*um / fm + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) - ustar = vonkar*um / fm + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu - ustar = vonkar*um / fm + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm ELSE ! 1 < zeta, phi=5+zeta - fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) - ustar = vonkar*um / fm + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm ENDIF ! for 10 meter wind-velocity @@ -92,14 +92,14 @@ SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& zeta=zldis/obu zetam=1.574 IF(zeta < -zetam)THEN ! zeta < -1 - fm10m = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + fm10m = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu ELSE ! 1 < zeta, phi=5+zeta - fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) ENDIF ! temperature profile @@ -107,14 +107,14 @@ SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fh = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF ! for 2 meter screen temperature @@ -122,14 +122,14 @@ SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF ! humidity profile @@ -137,14 +137,14 @@ SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fq = log(-zetat*obu/z0q) - psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu ELSE ! 1 < zeta, phi=5+zeta - fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) ENDIF ! for 2 meter screen humidity @@ -154,7 +154,7 @@ SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& IF(zeta < -zetat)THEN ! zeta < -1 fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - elseif (zeta < 0.) THEN ! -1 <= zeta < 0 + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) ELSE IF (zeta <= 1.) THEN ! 0 <= zeta <= 1 fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu @@ -232,18 +232,18 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& zeta=zldis/obu zetam=1.574 IF(zeta < -zetam)THEN ! zeta < -1 - fm = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) - ustar = vonkar*um / fm + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) - ustar = vonkar*um / fm + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu - ustar = vonkar*um / fm + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm ELSE ! 1 < zeta, phi=5+zeta - fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) - ustar = vonkar*um / fm + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm ENDIF ! for canopy top wind-velocity @@ -252,14 +252,14 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& zeta=zldis/obu zetam=1.574 IF(zeta < -zetam)THEN ! zeta < -1 - fmtop = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + fmtop = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu ELSE ! 1 < zeta, phi=5+zeta - fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) ENDIF ! temperature profile @@ -267,14 +267,14 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fh = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF ! for 2 meter screen temperature @@ -282,14 +282,14 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF ! for top layer temperature @@ -297,14 +297,14 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fht = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fht = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF ! for canopy top phi(h) @@ -327,14 +327,14 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fq = log(-zetat*obu/z0q) - psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu ELSE ! 1 < zeta, phi=5+zeta - fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) ENDIF ! for 2 meter screen humidity @@ -344,7 +344,7 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& IF(zeta < -zetat)THEN ! zeta < -1 fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - elseif (zeta < 0.) THEN ! -1 <= zeta < 0 + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) ELSE IF (zeta <= 1.) THEN ! 0 <= zeta <= 1 fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu @@ -359,7 +359,7 @@ SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& IF(zeta < -zetat)THEN ! zeta < -1 fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - elseif (zeta < 0.) THEN ! -1 <= zeta < 0 + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) ELSE IF (zeta <= 1.) THEN ! 0 <= zeta <= 1 fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu @@ -454,28 +454,28 @@ real(r8) FUNCTION kintmoninobuk(displa,z0h,obu,ustar,ztop,zbot) zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fh_top = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fh_top = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fh_top = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fh_top = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fh_top = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fh_top = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fh_top = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fh_top = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF zldis=zbot-displa zeta=zldis/obu zetat=0.465 IF(zeta < -zetat)THEN ! zeta < -1 - fh_bot = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + fh_bot = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 - fh_bot = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + fh_bot = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 - fh_bot = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + fh_bot = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu ELSE ! 1 < zeta, phi=5+zeta - fh_bot = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + fh_bot = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) ENDIF kintmoninobuk = 1./(vonkar/(fh_top-fh_bot)*ustar) diff --git a/main/MOD_Glacier.F90 b/main/MOD_Glacier.F90 index 71cf13f6..1482b123 100644 --- a/main/MOD_Glacier.F90 +++ b/main/MOD_Glacier.F90 @@ -285,11 +285,11 @@ SUBROUTINE GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& qseva = min(wliq_icesno(lb)/deltim, fevpg) qsubl = fevpg - qseva ELSE - IF(t_grnd < tfrz)THEN - qfros = abs(fevpg) - ELSE - qsdew = abs(fevpg) - ENDIF + IF(t_grnd < tfrz)THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF ENDIF ! ground heat flux @@ -322,12 +322,12 @@ SUBROUTINE GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ENDDO #if (defined CoLMDEBUG) - IF(abs(errore)>.2)THEN - write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' - write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) - STOP - ENDIF -100 format(10(f7.3)) + IF(abs(errore)>.2)THEN + write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' + write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) + STOP + ENDIF +100 format(10(f7.3)) #endif END SUBROUTINE GLACIER_TEMP @@ -684,7 +684,7 @@ SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv IF(lb<=0)THEN - cv(:0) = cpliq*wliq_icesno(:0) + cpice*wice_icesno(:0) + cv(:0) = cpliq*wliq_icesno(:0) + cpice*wice_icesno(:0) ENDIF ! SNOW and LAND ICE thermal conductivity [W/(m K)] @@ -694,24 +694,24 @@ SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& ENDDO IF(lb < 1)THEN - DO j = lb, 0 - rhosnow = (wice_icesno(j)+wliq_icesno(j))/dz_icesno(j) - - ! presently option [1] is the default option - ! [1] Jordan (1991) pp. 18 - thk(j) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) - - ! [2] Sturm et al (1997) - ! thk(j) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 - ! [3] Ostin and Andersson presented in Sturm et al., (1997) - ! thk(j) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 - ! [4] Jansson(1901) presented in Sturm et al. (1997) - ! thk(j) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 - ! [5] Douville et al., (1995) - ! thk(j) = 2.2*(rhosnow/denice)**1.88 - ! [6] van Dusen (1992) presented in Sturm et al. (1997) - ! thk(j) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 - ENDDO + DO j = lb, 0 + rhosnow = (wice_icesno(j)+wliq_icesno(j))/dz_icesno(j) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(j) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(j) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(j) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(j) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(j) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(j) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + ENDDO ENDIF ! Thermal conductivity at the layer interface @@ -755,7 +755,7 @@ SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& ENDDO DO j = lb, nl_ice - 1 - fn(j) = tk(j)*(t_icesno(j+1)-t_icesno(j))/(z_icesno(j+1)-z_icesno(j)) + fn(j) = tk(j)*(t_icesno(j+1)-t_icesno(j))/(z_icesno(j+1)-z_icesno(j)) ENDDO fn(nl_ice) = 0. @@ -769,14 +769,14 @@ SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& ! Hua Yuan, January 12, 2023 IF (lb <= 0) THEN - DO j = lb + 1, 1 - dzm = (z_icesno(j)-z_icesno(j-1)) - dzp = (z_icesno(j+1)-z_icesno(j)) - at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm - bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) - ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - rt(j) = t_icesno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - ENDDO + DO j = lb + 1, 1 + dzm = (z_icesno(j)-z_icesno(j-1)) + dzp = (z_icesno(j+1)-z_icesno(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_icesno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO ENDIF diff --git a/main/MOD_Hist.F90 b/main/MOD_Hist.F90 index 4f219daf..881d049d 100644 --- a/main/MOD_Hist.F90 +++ b/main/MOD_Hist.F90 @@ -159,12 +159,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & logical, allocatable :: filter_urb (:) #endif - if (itstamp <= ptstamp) then + IF (itstamp <= ptstamp) THEN CALL FLUSH_acc_fluxes () RETURN - else + ELSE CALL accumulate_fluxes () - END if + ENDIF select CASE (trim(adjustl(DEF_HIST_FREQ))) CASE ('TIMESTEP') @@ -181,37 +181,37 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & write(*,*) 'Warning : Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.' END select - if (lwrite) then + IF (lwrite) THEN CALL julian2monthday(idate(1), idate(2), month, day) days_month = (/31,28,31,30,31,30,31,31,30,31,30,31/) - if (isleapyear(idate(1))) days_month(2) = 29 + IF (isleapyear(idate(1))) days_month(2) = 29 - if ( trim(DEF_HIST_groupby) == 'YEAR' ) then + IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN write(cdate,'(i4.4)') idate(1) #ifdef SinglePoint IF (USE_SITE_HistWriteBack) THEN memory_to_disk = isendofyear(idate,deltim) .or. (.not. (itstamp < etstamp)) ENDIF #endif - elseif ( trim(DEF_HIST_groupby) == 'MONTH' ) then + ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN write(cdate,'(i4.4,"-",i2.2)') idate(1), month #ifdef SinglePoint IF (USE_SITE_HistWriteBack) THEN memory_to_disk = isendofmonth(idate,deltim) .or. (.not. (itstamp < etstamp)) ENDIF #endif - elseif ( trim(DEF_HIST_groupby) == 'DAY' ) then + ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN write(cdate,'(i4.4,"-",i2.2,"-",i2.2)') idate(1), month, day #ifdef SinglePoint IF (USE_SITE_HistWriteBack) THEN memory_to_disk = isendofday(idate,deltim) .or. (.not. (itstamp < etstamp)) ENDIF #endif - else + ELSE write(*,*) 'Warning : Please USE one of DAY/MONTH/YEAR for history group.' - END if + ENDIF #if(defined CaMa_Flood) ! add variables to write cama-flood output. @@ -225,13 +225,13 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL hist_write_time (file_hist, 'time', idate, itime_in_file) - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN allocate (filter (numpatch)) allocate (VecOnes (numpatch)) allocate (vecacc (numpatch)) VecOnes(:) = 1.0_r8 - END if + ENDIF #ifdef URBAN_MODEL IF (numurban > 0) THEN allocate (filter_urb (numurban)) @@ -239,22 +239,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & VecOnes_urb(:) = 1.0_r8 ENDIF #endif - END if + ENDIF IF (HistForm == 'Gridded') THEN - if (p_is_io) then + IF (p_is_io) THEN CALL allocate_block_data (ghist, sumarea) #ifdef URBAN_MODEL CALL allocate_block_data (ghist, sumarea_urb) #endif - END if + ENDIF ENDIF ! --------------------------------------------------- ! Meteorological forcing and patch mask filter applying. ! --------------------------------------------------- - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype < 99 @@ -263,15 +263,15 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF IF (HistForm == 'Gridded') THEN - IF (itime_in_file == 1) then + IF (itime_in_file == 1) THEN CALL hist_write_var_real8_2d (file_hist, 'landarea', ghist, 1, sumarea, & compress = 1, longname = 'land area', units = 'km2') ENDIF @@ -332,18 +332,18 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_snow, file_hist, 'f_xy_snow', itime_in_file, sumarea, filter, & 'snow','mm/s') - if (DEF_USE_CBL_HEIGHT) then + IF (DEF_USE_CBL_HEIGHT) THEN ! atmospheric boundary layer height [m] CALL write_history_variable_2d ( DEF_hist_vars%xy_hpbl, & a_hpbl, file_hist, 'f_xy_hpbl', itime_in_file, sumarea, filter, & 'boundary layer height','m') - endif + ENDIF ! ------------------------------------------------------------------------------------------ ! Mapping the fluxes and state variables at patch [numpatch] to grid ! ------------------------------------------------------------------------------------------ - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype < 99 @@ -352,8 +352,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -621,8 +621,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, & '2 m height air specific humidity','kg/kg') - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype == 2 @@ -631,8 +631,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF ! wetland water storage [mm] CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & @@ -653,8 +653,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! ------------------------------------------------------------------------------------------ #ifdef URBAN_MODEL - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN DO i = 1, numpatch IF (patchtype(i) == 1) THEN u = patch2urban(i) @@ -666,8 +666,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ENDIF ENDDO - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist_urb%map (VecOnes_urb, sumarea_urb, spv = spval, msk = filter_urb) @@ -777,14 +777,14 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! ------------------------------------------------------------------------------------------ ! Mapping the fluxes and state variables at patch [numpatch] to grid ! ------------------------------------------------------------------------------------------ - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype < 99 IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1100,11 +1100,11 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'crop phase','unitless') ! heat unit index - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_hui (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%hui, & vecacc, file_hist, 'f_hui', itime_in_file, sumarea, filter, & @@ -1140,11 +1140,11 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_cropseedc_deficit, file_hist, 'f_cropseedc_deficit', itime_in_file, sumarea, filter, & 'crop seed deficit','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF ! grain to crop production carbon CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_cropprodc, & vecacc, file_hist, 'f_grainc_to_cropprodc', itime_in_file, sumarea, filter, & @@ -1159,7 +1159,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fert_to_sminn, file_hist, 'f_fert_to_sminn', itime_in_file, sumarea, filter, & 'fertilization','gN/m2/s') - if(DEF_USE_IRRIGATION)then + IF(DEF_USE_IRRIGATION)THEN ! irrigation rate mm/s in 4h is averaged to the given time resolution mm/s CALL write_history_variable_2d ( DEF_hist_vars%irrig_rate, & a_irrig_rate, file_hist, 'f_irrig_rate', itime_in_file, sumarea, filter, & @@ -1176,7 +1176,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, & a_sum_irrig_count, file_hist, 'f_sum_irrig_count', itime_in_file, sumarea, filter, & 'total irrigation times at growing season','-') - END if + ENDIF #endif ! grain to crop seed carbon @@ -1281,7 +1281,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_OM_density, file_hist, 'f_OM_density', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'organic matter density in soil layers','kg/m3') - if (DEF_USE_NITRIF) then + IF (DEF_USE_NITRIF) THEN ! O2 soil Concentration for non-inundated area CALL write_history_variable_3d ( DEF_hist_vars%CONC_O2_UNSAT, & a_conc_o2_unsat, file_hist, 'f_CONC_O2_UNSAT', itime_in_file, 'soil', 1, nl_soil, & @@ -1291,9 +1291,9 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL write_history_variable_3d ( DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT, & a_o2_decomp_depth_unsat, file_hist, 'f_O2_DECOMP_DEPTH_UNSAT', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'O2 consumption from HR and AR for non-inundated area','mol/m3/s') - END if + ENDIF - if (DEF_USE_FIRE) then + IF (DEF_USE_FIRE) THEN CALL write_history_variable_2d ( DEF_hist_vars%abm, & vecacc, file_hist, 'f_abm', itime_in_file, sumarea, filter, & 'peak crop fire month','unitless') @@ -1313,22 +1313,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL write_history_variable_2d ( DEF_hist_vars%lnfm, & vecacc, file_hist, 'f_lnfm', itime_in_file, sumarea, filter, & 'lnfm','unitless') - END if + ENDIF - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) .ne. 12 .and. patchtype(i) .eq. 0)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) .ne. 12 .and. patchtype(i) .eq. 0)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF - IF (HistForm == 'Gridded') then + IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF @@ -1474,52 +1474,52 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #ifdef CROP !***************************************** - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_hui (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%huiswheat, & vecacc, file_hist, 'f_huiswheat', itime_in_file, sumarea, filter, & 'heat unit index (rainfed spring wheat)','unitless') !************************************************************ - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & - .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & + .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1529,21 +1529,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdcorn, file_hist, 'f_pdcorn', & itime_in_file, sumarea, filter, 'planting date of corn', 'day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1553,21 +1553,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdswheat, file_hist, 'f_pdswheat', & itime_in_file, sumarea, filter,'planting date of spring wheat','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1577,22 +1577,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdwwheat, file_hist, 'f_pdwwheat', & itime_in_file, sumarea, filter,'planting date of winter wheat','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & - .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & + .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1602,21 +1602,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdsoybean, file_hist, 'f_pdsoybean', & itime_in_file, sumarea, filter,'planting date of soybean','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1626,21 +1626,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdcotton, file_hist, 'f_pdcotton', & itime_in_file, sumarea, filter,'planting date of cotton','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1650,21 +1650,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdrice1, file_hist, 'f_pdrice1', & itime_in_file, sumarea, filter,'planting date of rice1','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1674,21 +1674,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdrice2, file_hist, 'f_pdrice2', & itime_in_file, sumarea, filter,'planting date of rice2','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1698,22 +1698,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_pdsugarcane, file_hist, 'f_pdsugarcane', & itime_in_file, sumarea, filter,'planting date of sugarcane','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & - .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & + .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1723,21 +1723,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_corn, file_hist, 'f_fertnitro_corn', & itime_in_file, sumarea, filter,'nitrogen fertilizer for corn','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1747,21 +1747,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_swheat, file_hist, 'f_fertnitro_swheat', & itime_in_file, sumarea, filter,'nitrogen fertilizer for spring wheat','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1771,22 +1771,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_wwheat, file_hist, 'f_fertnitro_wwheat', & itime_in_file, sumarea, filter,'nitrogen fertilizer for winter wheat','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & - .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & + .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1796,21 +1796,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_soybean, file_hist, 'f_fertnitro_soybean', & itime_in_file, sumarea, filter,'nitrogen fertilizer for soybean','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1820,21 +1820,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_cotton, file_hist, 'f_fertnitro_cotton', & itime_in_file, sumarea, filter,'nitrogen fertilizer for cotton','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1844,21 +1844,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_rice1, file_hist, 'f_fertnitro_rice1', & itime_in_file, sumarea, filter,'nitrogen fertilizer for rice1','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1868,21 +1868,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_rice2, file_hist, 'f_fertnitro_rice2', & itime_in_file, sumarea, filter,'nitrogen fertilizer for rice2','gN/m2/yr') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1892,22 +1892,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_sugarcane, file_hist, 'f_fertnitro_sugarcane', & itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr') - if(DEF_USE_IRRIGATION)THEN - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 17)then + IF(DEF_USE_IRRIGATION)THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1917,21 +1917,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_corn, file_hist, 'f_irrig_method_corn', & itime_in_file, sumarea, filter,'irrigation method for corn','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1941,21 +1941,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', & itime_in_file, sumarea, filter,'irrigation method for spring wheat','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1965,22 +1965,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', & itime_in_file, sumarea, filter,'irrigation method for winter wheat','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & - .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & + .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -1990,21 +1990,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', & itime_in_file, sumarea, filter,'irrigation method for soybean','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -2014,21 +2014,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', & itime_in_file, sumarea, filter,'irrigation method for cotton','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -2038,21 +2038,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', & itime_in_file, sumarea, filter,'irrigation method for rice1','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -2062,21 +2062,21 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', & itime_in_file, sumarea, filter,'irrigation method for rice2','-') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -2086,83 +2086,83 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_sugarcane, file_hist, 'f_irrig_method_sugarcane', & itime_in_file, sumarea, filter,'irrigation method for sugarcane','-') - END if + ENDIF - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 17)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed temperate corn - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, & vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed temperate corn)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 18)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 18)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated temperate corn - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, & vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated temperate corn)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 19)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN @@ -2170,30 +2170,30 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed spring wheat - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, & vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed spring wheat)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 20)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 20)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN @@ -2201,450 +2201,450 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated spring wheat - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, & vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated spring wheat)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 21)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed winter wheat - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, & vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed winter wheat)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 22)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 22)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated winter wheat - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, & vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated winter wheat)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 23)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed temperate soybean - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, & vecacc, file_hist, 'f_plantdate_rainfed_temp_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed temperate soybean)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 24)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 24)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated temperate soybean - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, & vecacc, file_hist, 'f_plantdate_irrigated_temp_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated temperate soybean)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 41)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed cotton - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, & vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed cotton)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 42)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 42)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated cotton - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, & vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated cotton)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed rice - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, & vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed rice)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated rice - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, & vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated rice)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 67)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed sugarcane - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, & vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed sugarcane)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 68)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 68)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated sugarcane - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, & vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated sugarcane)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 75)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 75)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed trop corn - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, & vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed trop corn)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 76)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 76)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated trop corn - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, & vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated trop corn)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 77)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 77)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed trop soybean - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, & vecacc, file_hist, 'f_plantdate_rainfed_trop_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed trop soybean)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 78)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 78)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated trop soybean - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, & vecacc, file_hist, 'f_plantdate_irrigated_trop_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated trop soybean)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 15)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 15)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN @@ -2652,581 +2652,581 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of unmanaged crop production - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, & vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, & 'Crop planting date (unmanaged crop production)','day') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 17)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to corn production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_corn, & vecacc, file_hist, 'f_cropprodc_rainfed_temp_corn', itime_in_file, sumarea, filter, & 'Crop production (rainfed temperate corn)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 18)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 18)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to corn production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_corn, & vecacc, file_hist, 'f_cropprodc_irrigated_temp_corn', itime_in_file, sumarea, filter, & 'Crop production (irrigated temperate corn)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 19)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to spring wheat production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_spwheat, & vecacc, file_hist, 'f_cropprodc_rainfed_spwheat', itime_in_file, sumarea, filter, & 'Crop production (rainfed spring wheat)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 20)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 20)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to spring wheat production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_spwheat, & vecacc, file_hist, 'f_cropprodc_irrigated_spwheat', itime_in_file, sumarea, filter, & 'Crop production (irrigated spring wheat)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 21)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to winter wheat production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_wtwheat, & vecacc, file_hist, 'f_cropprodc_rainfed_wtwheat', itime_in_file, sumarea, filter, & 'Crop production (rainfed winter wheat)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 22)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 22)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to winter wheat production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_wtwheat, & vecacc, file_hist, 'f_cropprodc_irrigated_wtwheat', itime_in_file, sumarea, filter, & 'Crop production (irrigated winter wheat)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 23)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to soybean production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_soybean, & vecacc, file_hist, 'f_cropprodc_rainfed_temp_soybean', itime_in_file, sumarea, filter, & 'Crop production (rainfed temperate soybean)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 24)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 24)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to soybean production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_soybean, & vecacc, file_hist, 'f_cropprodc_irrigated_temp_soybean', itime_in_file, sumarea, filter, & 'Crop production (irrigated temperate soybean)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 41)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to cotton production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_cotton, & vecacc, file_hist, 'f_cropprodc_rainfed_cotton', itime_in_file, sumarea, filter, & 'Crop production (rainfed cotton)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 42)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 42)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to cotton production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_cotton, & vecacc, file_hist, 'f_cropprodc_irrigated_cotton', itime_in_file, sumarea, filter, & 'Crop production (irrigated cotton)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 61)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to rice production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_rice, & vecacc, file_hist, 'f_cropprodc_rainfed_rice', itime_in_file, sumarea, filter, & 'Crop production (rainfed rice)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 62)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 62)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to rice production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_rice, & vecacc, file_hist, 'f_cropprodc_irrigated_rice', itime_in_file, sumarea, filter, & 'Crop production (irrigated rice)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 67)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_sugarcane, & vecacc, file_hist, 'f_cropprodc_rainfed_sugarcane', itime_in_file, sumarea, filter, & 'Crop production (rainfed sugarcane)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 68)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 68)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_sugarcane, & vecacc, file_hist, 'f_cropprodc_irrigated_sugarcane', itime_in_file, sumarea, filter, & 'Crop production (irrigated sugarcane)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 75)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 75)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_corn, & vecacc, file_hist, 'f_cropprodc_rainfed_trop_corn', itime_in_file, sumarea, filter, & 'Crop production (rainfed_trop_corn)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 76)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 76)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_corn, & vecacc, file_hist, 'f_cropprodc_irrigated_trop_corn', itime_in_file, sumarea, filter, & 'Crop production (irrigated_trop_corn)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 77)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 77)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_soybean, & vecacc, file_hist, 'f_cropprodc_rainfed_trop_soybean', itime_in_file, sumarea, filter, & 'Crop production (rainfed trop soybean)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 78)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 78)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_soybean, & vecacc, file_hist, 'f_cropprodc_irrigated_trop_soybean', itime_in_file, sumarea, filter, & 'Crop production (irrigated trop soybean)','gC/m2/s') - if (p_is_worker) then - if (numpatch > 0) then - do i=1,numpatch - if(patchclass(i) == 12)then - if(pftclass(patch_pft_s(i)) .eq. 15)then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 15)THEN filter(i) = .true. - else + ELSE filter(i) = .false. - END if - else + ENDIF + ELSE filter(i) = .false. - END if - END do - END if - END if + ENDIF + ENDDO + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to unmanaged crop production carbon - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) - END if - END if + ENDIF + ENDIF CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_unmanagedcrop, & vecacc, file_hist, 'f_cropprodc_unmanagedcrop', itime_in_file, sumarea, filter, & 'Crop production (unmanaged crop production)','gC/m2/s') @@ -3238,8 +3238,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! land water bodies => 4; ocean => 99] ! -------------------------------------------------------------------- - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype <= 3 @@ -3248,8 +3248,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -3276,8 +3276,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! land water bodies => 4; ocean => 99] ! -------------------------------------------------------------------- - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype <= 2 @@ -3286,8 +3286,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -3304,12 +3304,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_rootr, file_hist, 'f_rootr', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & 'root water uptake', 'mm h2o/s') - if (DEF_USE_PLANTHYDRAULICS) then + IF (DEF_USE_PLANTHYDRAULICS) THEN ! vegetation water potential [mm] CALL write_history_variable_3d ( DEF_hist_vars%vegwp, & a_vegwp, file_hist, 'f_vegwp', itime_in_file, 'vegnodes', 1, nvegwcs, sumarea, filter, & 'vegetation water potential', 'mm') - END if + ENDIF ! water table depth [m] CALL write_history_variable_2d ( DEF_hist_vars%zwt, & @@ -3319,8 +3319,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------------------------------------------- ! depth of surface water (including land ice and ocean patches) ! -------------------------------------------------------------------- - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = (patchtype <= 4) @@ -3329,8 +3329,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -3368,14 +3368,14 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! Land water bodies' ice fraction and temperature ! ----------------------------------------------- - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype == 4 IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -3394,8 +3394,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------- ! Retrieve through averaged fluxes ! -------------------------------- - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = patchtype < 99 @@ -3404,8 +3404,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -3517,14 +3517,14 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'reflected diffuse beam nir solar radiation (W/m2)','W/m2') ! local noon fluxes - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN filter(:) = nac_ln > 0 IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF - END if - END if + ENDIF + ENDIF IF (HistForm == 'Gridded') THEN CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) @@ -3574,7 +3574,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) then + IF (p_is_master) THEN CALL hist_out_cama (file_hist_cama, itime_in_file_cama) ENDIF #endif @@ -3583,11 +3583,11 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL hist_basin_out (file_hist, idate) #endif - if (allocated(filter )) deallocate (filter ) - if (allocated(VecOnes)) deallocate (VecOnes) + IF (allocated(filter )) deallocate (filter ) + IF (allocated(VecOnes)) deallocate (VecOnes) #ifdef URBAN_MODEL - if (allocated(filter_urb )) deallocate(filter_urb ) - if (allocated(VecOnes_urb)) deallocate(VecOnes_urb) + IF (allocated(filter_urb )) deallocate(filter_urb ) + IF (allocated(VecOnes_urb)) deallocate(VecOnes_urb) #endif CALL FLUSH_acc_fluxes () @@ -3598,7 +3598,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF #endif - END if + ENDIF END SUBROUTINE hist_out @@ -3621,7 +3621,7 @@ SUBROUTINE write_history_variable_2d ( is_hist, & type(block_data_real8_2d), intent(in) :: sumarea logical, intent(in) :: filter(:) - if (.not. is_hist) RETURN + IF (.not. is_hist) RETURN select CASE (HistForm) CASE ('Gridded') @@ -3661,7 +3661,7 @@ SUBROUTINE write_history_variable_urb_2d ( is_hist, & type(block_data_real8_2d), intent(in) :: sumarea logical, intent(in) :: filter(:) - if (.not. is_hist) RETURN + IF (.not. is_hist) RETURN select CASE (HistForm) CASE ('Gridded') @@ -3707,7 +3707,7 @@ SUBROUTINE write_history_variable_3d ( is_hist, & integer :: iblkme, xblk, yblk, xloc, yloc, i1 integer :: compress - if (.not. is_hist) RETURN + IF (.not. is_hist) RETURN select CASE (HistForm) CASE ('Gridded') @@ -3751,7 +3751,7 @@ SUBROUTINE write_history_variable_4d ( is_hist, & character (len=*), intent(in) :: longname character (len=*), intent(in) :: units - if (.not. is_hist) RETURN + IF (.not. is_hist) RETURN select CASE (HistForm) CASE ('Gridded') @@ -3792,7 +3792,7 @@ SUBROUTINE write_history_variable_ln ( is_hist, & character (len=*), intent(in), optional :: longname character (len=*), intent(in), optional :: units - if (.not. is_hist) RETURN + IF (.not. is_hist) RETURN select CASE (HistForm) CASE ('Gridded') diff --git a/main/MOD_Irrigation.F90 b/main/MOD_Irrigation.F90 index 21c6e2c0..ea2bc5f2 100644 --- a/main/MOD_Irrigation.F90 +++ b/main/MOD_Irrigation.F90 @@ -151,31 +151,31 @@ SUBROUTINE CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) ! calculate total irrigation needed in all soil layers DO m = ps, pe - DO j = 1, nl_soil - IF (.not. reached_max_depth) THEN - IF (z_soi(j) > irrig_max_depth) THEN - reached_max_depth = .true. - ELSE IF (j > nbedrock) THEN - reached_max_depth = .true. - ELSE IF (t_soisno(j,i) <= tfrz) THEN - reached_max_depth = .true. + DO j = 1, nl_soil + IF (.not. reached_max_depth) THEN + IF (z_soi(j) > irrig_max_depth) THEN + reached_max_depth = .true. + ELSEIF (j > nbedrock) THEN + reached_max_depth = .true. + ELSEIF (t_soisno(j,i) <= tfrz) THEN + reached_max_depth = .true. + ELSE + h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) + h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) + IF (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler) THEN + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + ! irrigation threshold at field capacity, but irrigation amount at saturation capacity + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) + ELSEIF (irrig_method_p(m) == irrig_method_paddy) THEN + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_saturation_capacity(j) ELSE - h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) - h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) - IF (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler) THEN - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) - ! irrigation threshold at field capacity, but irrigation amount at saturation capacity - ELSE IF (irrig_method_p(m) == irrig_method_flood) THEN - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) - h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) - ELSE IF (irrig_method_p(m) == irrig_method_paddy) THEN - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_saturation_capacity(j) - ELSE - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) - ENDIF + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) ENDIF - ENDIF - ENDDO + ENDIF + ENDIF + ENDDO ENDDO ! calculate irrigation threshold @@ -184,18 +184,18 @@ SUBROUTINE CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) ! calculate total irrigation DO m = ps, pe - IF (h2osoi_liq_tot < h2osoi_liq_at_threshold) THEN - IF (irrig_method_p(m) == irrig_method_sprinkler) THEN - deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot - ! deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + potential_evapotranspiration(i) - ELSE IF (irrig_method_p(m) == irrig_method_flood) THEN - deficit_irrig(i) = h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot - ELSE - deficit_irrig(i) = h2osoi_liq_at_threshold - h2osoi_liq_tot - ENDIF - ELSE - deficit_irrig(i) = 0 - ENDIF + IF (h2osoi_liq_tot < h2osoi_liq_at_threshold) THEN + IF (irrig_method_p(m) == irrig_method_sprinkler) THEN + deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + ! deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + potential_evapotranspiration(i) + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + deficit_irrig(i) = h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot + ELSE + deficit_irrig(i) = h2osoi_liq_at_threshold - h2osoi_liq_tot + ENDIF + ELSE + deficit_irrig(i) = 0 + ENDIF ENDDO END SUBROUTINE CalIrrigationPotentialNeeded @@ -223,31 +223,31 @@ SUBROUTINE CalIrrigationApplicationFluxes(i,ps,pe,deltim,qflx_irrig_drip,qflx_ir ! add irrigation fluxes to precipitation or land surface DO m = ps, pe - IF (n_irrig_steps_left(i) > 0) THEN - IF ((irrig_flag == 1) .and. (irrig_method_p(m) == irrig_method_sprinkler)) THEN - qflx_irrig_sprinkler = irrig_rate(i) - n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 - deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim - ELSE IF (irrig_flag == 2) THEN - IF (irrig_method_p(m) == irrig_method_drip) THEN - qflx_irrig_drip = irrig_rate(i) - ELSE IF (irrig_method_p(m) == irrig_method_flood) THEN - qflx_irrig_flood = irrig_rate(i) - ELSE IF (irrig_method_p(m) == irrig_method_paddy) THEN - qflx_irrig_paddy = irrig_rate(i) - ELSE IF ((irrig_method_p(m) /= irrig_method_drip) .and. (irrig_method_p(m) /= irrig_method_sprinkler) & - .and. (irrig_method_p(m) /= irrig_method_flood) .and. (irrig_method_p(m) /= irrig_method_paddy)) THEN - qflx_irrig_drip = irrig_rate(i) - ENDIF - n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 - deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim - ENDIF - IF (deficit_irrig(i) < 0._r8) THEN - deficit_irrig(i) = 0._r8 - ENDIF - ELSE - irrig_rate(i) = 0._r8 - ENDIF + IF (n_irrig_steps_left(i) > 0) THEN + IF ((irrig_flag == 1) .and. (irrig_method_p(m) == irrig_method_sprinkler)) THEN + qflx_irrig_sprinkler = irrig_rate(i) + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim + ELSEIF (irrig_flag == 2) THEN + IF (irrig_method_p(m) == irrig_method_drip) THEN + qflx_irrig_drip = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + qflx_irrig_flood = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_paddy) THEN + qflx_irrig_paddy = irrig_rate(i) + ELSEIF ((irrig_method_p(m) /= irrig_method_drip) .and. (irrig_method_p(m) /= irrig_method_sprinkler) & + .and. (irrig_method_p(m) /= irrig_method_flood) .and. (irrig_method_p(m) /= irrig_method_paddy)) THEN + qflx_irrig_drip = irrig_rate(i) + ENDIF + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim + ENDIF + IF (deficit_irrig(i) < 0._r8) THEN + deficit_irrig(i) = 0._r8 + ENDIF + ELSE + irrig_rate(i) = 0._r8 + ENDIF ENDDO END SUBROUTINE CalIrrigationApplicationFluxes @@ -268,23 +268,23 @@ SUBROUTINE PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for real(r8):: seconds_since_irrig_start_time DO m = ps, pe - ivt = pftclass(m) - IF ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & - (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) THEN - check_for_irrig = .true. - ELSE - check_for_irrig = .false. - ENDIF - ELSE - check_for_irrig = .false. - ENDIF + ivt = pftclass(m) + IF ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & + (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) THEN + check_for_irrig = .true. + ELSE + check_for_irrig = .false. + ENDIF + ELSE + check_for_irrig = .false. + ENDIF ENDDO END SUBROUTINE PointNeedsCheckForIrrig diff --git a/main/MOD_LeafTemperature.F90 b/main/MOD_LeafTemperature.F90 index 09fe6326..3c534468 100644 --- a/main/MOD_LeafTemperature.F90 +++ b/main/MOD_LeafTemperature.F90 @@ -1082,11 +1082,11 @@ SUBROUTINE LeafTemperature ( & ldew_rain = ldew_rain-evplwet*deltim ldew_snow = ldew_snow ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC IF (ldew_rain .gt. evplwet*deltim) THEN diff --git a/main/MOD_PhaseChange.F90 b/main/MOD_PhaseChange.F90 index 323a5684..5aaa4490 100644 --- a/main/MOD_PhaseChange.F90 +++ b/main/MOD_PhaseChange.F90 @@ -51,6 +51,7 @@ SUBROUTINE meltf (patchtype,lb,nl_soil,deltim, & !----------------------------------------------------------------------- USE MOD_Precision + USE MOD_SPMD_Task USE MOD_Hydro_SoilFunction USE MOD_Const_Physical, only : tfrz, hfus,grav USE MOD_Namelist @@ -308,6 +309,7 @@ SUBROUTINE meltf (patchtype,lb,nl_soil,deltim, & we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we IF(abs(we)>1.e-6) THEN print*, 'meltf err : ', we + CALL CoLM_stop() ENDIF ENDIF @@ -347,6 +349,7 @@ SUBROUTINE meltf_snicar (patchtype,lb,nl_soil,deltim, & !----------------------------------------------------------------------- USE MOD_Precision + USE MOD_SPMD_Task USE MOD_Hydro_SoilFunction USE MOD_Const_Physical, only : tfrz, hfus, grav USE MOD_Namelist @@ -612,6 +615,7 @@ SUBROUTINE meltf_snicar (patchtype,lb,nl_soil,deltim, & we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we IF(abs(we)>1.e-6) THEN print*, 'meltf err : ', we + CALL CoLM_stop() ENDIF ENDIF @@ -639,6 +643,7 @@ SUBROUTINE meltf_urban (lb,nl_soil,deltim, & !----------------------------------------------------------------------- USE MOD_Precision + USE MOD_SPMD_Task USE MOD_Const_Physical, only : tfrz, hfus IMPLICIT NONE @@ -797,6 +802,7 @@ SUBROUTINE meltf_urban (lb,nl_soil,deltim, & we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we IF(abs(we)>1.e-6) THEN print*, 'meltf err : ', we + CALL CoLM_stop() ENDIF ENDIF diff --git a/main/MOD_Qsadv.F90 b/main/MOD_Qsadv.F90 index ea55797d..41e8a2e7 100644 --- a/main/MOD_Qsadv.F90 +++ b/main/MOD_Qsadv.F90 @@ -81,15 +81,15 @@ SUBROUTINE qsadv(T,p,es,esdT,qs,qsdT) IF (td > 75.0) td = 75.0 IF (td >= 0.0)THEN - es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & - + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) - esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & - + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) ELSE - es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & - + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) - esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & - + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) ENDIF es = es * 100. ! pa diff --git a/main/MOD_SnowLayersCombineDivide.F90 b/main/MOD_SnowLayersCombineDivide.F90 index 0fe8a7d8..e01a833c 100644 --- a/main/MOD_SnowLayersCombineDivide.F90 +++ b/main/MOD_SnowLayersCombineDivide.F90 @@ -342,71 +342,71 @@ SUBROUTINE snowlayerscombine (lb,snl, & ! two or more layers - IF(snl < -1)THEN - msn_old = snl - mssi = 1 - DO i = msn_old+1, 0 + IF(snl < -1)THEN + msn_old = snl + mssi = 1 + DO i = msn_old+1, 0 ! If top node is removed, combine with bottom neighbor - IF(dz_soisno(i) < dzmin(mssi))THEN - IF(i == snl+1)THEN - neibor = i + 1 + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN + neibor = i + 1 ! If the bottom neighbor is not snow, combine with the top neighbor - ELSE IF(i == 0)THEN - neibor = i - 1 + ELSE IF(i == 0)THEN + neibor = i - 1 ! If NONE of the above special cases apply, combine with the thinnest neighbor - ELSE - neibor = i + 1 - IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 - ENDIF + ELSE + neibor = i + 1 + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF ! Node l and j are combined and stored as node j. - IF(neibor > i)THEN - j = neibor - l = i - ELSE - j = i - l = neibor - ENDIF - CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& - dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) + IF(neibor > i)THEN + j = neibor + l = i + ELSE + j = i + l = neibor + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) ! Now shift all elements above this down one. - IF(j-1 > snl+1) THEN - DO k = j-1, snl+2, -1 - t_soisno(k) = t_soisno(k-1) - wice_soisno(k) = wice_soisno(k-1) - wliq_soisno(k) = wliq_soisno(k-1) - dz_soisno(k) = dz_soisno(k-1) - ENDDO - ENDIF + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 + t_soisno(k) = t_soisno(k-1) + wice_soisno(k) = wice_soisno(k-1) + wliq_soisno(k) = wliq_soisno(k-1) + dz_soisno(k) = dz_soisno(k-1) + ENDDO + ENDIF - snl = snl + 1 + snl = snl + 1 !* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j - IF(snl >= -1) EXIT + IF(snl >= -1) EXIT ! The layer thickness great than the prescibed minimum value - ELSE - mssi = mssi + 1 - ENDIF - ENDDO + ELSE + mssi = mssi + 1 + ENDIF + ENDDO - ENDIF + ENDIF ! Reset the node depth and the depth of layer interface - zi_soisno(0) = 0. - DO k = 0, snl+1, -1 - z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) - zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) - ENDDO + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO ENDIF !!! snow layers combined @@ -852,94 +852,94 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & ! two or more layers - IF(snl < -1)THEN - msn_old = snl - mssi = 1 - DO i = msn_old+1, 0 + IF(snl < -1)THEN + msn_old = snl + mssi = 1 + DO i = msn_old+1, 0 ! If top node is removed, combine with bottom neighbor - IF(dz_soisno(i) < dzmin(mssi))THEN - IF(i == snl+1)THEN - neibor = i + 1 + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN + neibor = i + 1 ! If the bottom neighbor is not snow, combine with the top neighbor - ELSE IF(i == 0)THEN - neibor = i - 1 + ELSE IF(i == 0)THEN + neibor = i - 1 ! If NONE of the above special cases apply, combine with the thinnest neighbor - ELSE - neibor = i + 1 - IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 - ENDIF + ELSE + neibor = i + 1 + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF ! Node l and j are combined and stored as node j. - IF(neibor > i)THEN - j = neibor - l = i - ELSE - j = i - l = neibor - ENDIF - CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& - dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) + IF(neibor > i)THEN + j = neibor + l = i + ELSE + j = i + l = neibor + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) !Aerosol Fluxes (January 07, 2023) - mss_bcphi(j) = mss_bcphi(j) + mss_bcphi(l) - mss_bcpho(j) = mss_bcpho(j) + mss_bcpho(l) - mss_ocphi(j) = mss_ocphi(j) + mss_ocphi(l) - mss_ocpho(j) = mss_ocpho(j) + mss_ocpho(l) - mss_dst1 (j) = mss_dst1 (j) + mss_dst1 (l) - mss_dst2 (j) = mss_dst2 (j) + mss_dst2 (l) - mss_dst3 (j) = mss_dst3 (j) + mss_dst3 (l) - mss_dst4 (j) = mss_dst4 (j) + mss_dst4 (l) + mss_bcphi(j) = mss_bcphi(j) + mss_bcphi(l) + mss_bcpho(j) = mss_bcpho(j) + mss_bcpho(l) + mss_ocphi(j) = mss_ocphi(j) + mss_ocphi(l) + mss_ocpho(j) = mss_ocpho(j) + mss_ocpho(l) + mss_dst1 (j) = mss_dst1 (j) + mss_dst1 (l) + mss_dst2 (j) = mss_dst2 (j) + mss_dst2 (l) + mss_dst3 (j) = mss_dst3 (j) + mss_dst3 (l) + mss_dst4 (j) = mss_dst4 (j) + mss_dst4 (l) !Aerosol Fluxes (January 07, 2023) ! Now shift all elements above this down one. - IF(j-1 > snl+1) THEN - DO k = j-1, snl+2, -1 - t_soisno(k) = t_soisno(k-1) - wice_soisno(k) = wice_soisno(k-1) - wliq_soisno(k) = wliq_soisno(k-1) - dz_soisno(k) = dz_soisno(k-1) + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 + t_soisno(k) = t_soisno(k-1) + wice_soisno(k) = wice_soisno(k-1) + wliq_soisno(k) = wliq_soisno(k-1) + dz_soisno(k) = dz_soisno(k-1) !Aerosol Fluxes (January 07, 2023) - mss_bcphi(k) = mss_bcphi(k-1) - mss_bcpho(k) = mss_bcpho(k-1) - mss_ocphi(k) = mss_ocphi(k-1) - mss_ocpho(k) = mss_ocpho(k-1) - mss_dst1 (k) = mss_dst1 (k-1) - mss_dst2 (k) = mss_dst2 (k-1) - mss_dst3 (k) = mss_dst3 (k-1) - mss_dst4 (k) = mss_dst4 (k-1) + mss_bcphi(k) = mss_bcphi(k-1) + mss_bcpho(k) = mss_bcpho(k-1) + mss_ocphi(k) = mss_ocphi(k-1) + mss_ocpho(k) = mss_ocpho(k-1) + mss_dst1 (k) = mss_dst1 (k-1) + mss_dst2 (k) = mss_dst2 (k-1) + mss_dst3 (k) = mss_dst3 (k-1) + mss_dst4 (k) = mss_dst4 (k-1) !Aerosol Fluxes (January 07, 2023) - ENDDO - ENDIF + ENDDO + ENDIF - snl = snl + 1 + snl = snl + 1 !* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j - IF(snl >= -1) EXIT + IF(snl >= -1) EXIT ! The layer thickness great than the prescibed minimum value - ELSE - mssi = mssi + 1 - ENDIF - ENDDO + ELSE + mssi = mssi + 1 + ENDIF + ENDDO - ENDIF + ENDIF ! Reset the node depth and the depth of layer interface - zi_soisno(0) = 0._r8 - DO k = 0, snl+1, -1 - z_soisno(k) = zi_soisno(k) - 0.5_r8*dz_soisno(k) - zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) - ENDDO + zi_soisno(0) = 0._r8 + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5_r8*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO ENDIF !!! snow layers combined @@ -1033,211 +1033,211 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& IF(msno == 1)THEN IF(dzsno(1) > 0.03)THEN - msno = 2 + msno = 2 ! Specified a new snow layer - dzsno(1) = dzsno(1)/2. - swice(1) = swice(1)/2. - swliq(1) = swliq(1)/2. + dzsno(1) = dzsno(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. !Aerosol Fluxes (January 07, 2023) - mss_aerosol(1,:) = mss_aerosol(1,:)/2. + mss_aerosol(1,:) = mss_aerosol(1,:)/2. !Aerosol Fluxes (January 07, 2023) - dzsno(2) = dzsno(1) - swice(2) = swice(1) - swliq(2) = swliq(1) + dzsno(2) = dzsno(1) + swice(2) = swice(1) + swliq(2) = swliq(1) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(2,:) = mss_aerosol(1,:) + mss_aerosol(2,:) = mss_aerosol(1,:) !Aerosol Fluxes (January 07, 2023) - tsno(2) = tsno(1) + tsno(2) = tsno(1) -! write(6,*)'Subdivided Top Node into two layer (1/2)' +! write(6,*)'Subdivided Top Node into two layer (1/2)' ENDIF ENDIF IF(msno > 1)THEN IF(dzsno(1) > 0.02)THEN - drr = dzsno(1) - 0.02 - propor = drr/dzsno(1) - zwice = propor*swice(1) - zwliq = propor*swliq(1) + drr = dzsno(1) - 0.02 + propor = drr/dzsno(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) !Aerosol Fluxes (January 07, 2023) - z_mss_aerosol(:) = propor*mss_aerosol(1,:) + z_mss_aerosol(:) = propor*mss_aerosol(1,:) !Aerosol Fluxes (January 07, 2023) - propor = 0.02/dzsno(1) - swice(1) = propor*swice(1) - swliq(1) = propor*swliq(1) + propor = 0.02/dzsno(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(1,:) = propor*mss_aerosol(1,:) + mss_aerosol(1,:) = propor*mss_aerosol(1,:) !Aerosol Fluxes (January 07, 2023) - dzsno(1) = 0.02 + dzsno(1) = 0.02 - CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & - drr,zwliq,zwice,tsno(1)) + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & + drr,zwliq,zwice,tsno(1)) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(2,:) = z_mss_aerosol(:) + mss_aerosol(2,:) + mss_aerosol(2,:) = z_mss_aerosol(:) + mss_aerosol(2,:) !Aerosol Fluxes (January 07, 2023) -! write(6,*) 'Subdivided Top Node & -! 20 mm combined into underlying neighbor' +! write(6,*) 'Subdivided Top Node & +! 20 mm combined into underlying neighbor' - IF(msno <= 2 .and. dzsno(2) > 0.07)THEN + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN ! subdivided a new layer - msno = 3 - dzsno(2) = dzsno(2)/2. - swice(2) = swice(2)/2. - swliq(2) = swliq(2)/2. + msno = 3 + dzsno(2) = dzsno(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. !Aerosol Fluxes (January 07, 2023) - mss_aerosol(2,:) = mss_aerosol(2,:)/2. + mss_aerosol(2,:) = mss_aerosol(2,:)/2. !Aerosol Fluxes (January 07, 2023) - dzsno(3) = dzsno(2) - swice(3) = swice(2) - swliq(3) = swliq(2) + dzsno(3) = dzsno(2) + swice(3) = swice(2) + swliq(3) = swliq(2) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(3,:) = mss_aerosol(2,:) + mss_aerosol(3,:) = mss_aerosol(2,:) !Aerosol Fluxes (January 07, 2023) - tsno(3) = tsno(2) - ENDIF + tsno(3) = tsno(2) + ENDIF ENDIF ENDIF IF(msno > 2)THEN IF(dzsno(2) > 0.05)THEN - drr = dzsno(2) - 0.05 - propor = drr/dzsno(2) - zwice = propor*swice(2) - zwliq = propor*swliq(2) + drr = dzsno(2) - 0.05 + propor = drr/dzsno(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) !Aerosol Fluxes (January 07, 2023) - z_mss_aerosol(:) = propor*mss_aerosol(2,:) + z_mss_aerosol(:) = propor*mss_aerosol(2,:) !Aerosol Fluxes (January 07, 2023) - propor = 0.05/dzsno(2) - swice(2) = propor*swice(2) - swliq(2) = propor*swliq(2) + propor = 0.05/dzsno(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(2,:) = propor*mss_aerosol(2,:) + mss_aerosol(2,:) = propor*mss_aerosol(2,:) !Aerosol Fluxes (January 07, 2023) - dzsno(2) = 0.05 + dzsno(2) = 0.05 - CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & - drr, zwliq, zwice, tsno(2)) + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & + drr, zwliq, zwice, tsno(2)) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(3,:) = z_mss_aerosol(:) + mss_aerosol(3,:) + mss_aerosol(3,:) = z_mss_aerosol(:) + mss_aerosol(3,:) !Aerosol Fluxes (January 07, 2023) -! write(6,*)'Subdivided 50 mm from the subsface layer & -! &and combined into underlying neighbor' +! write(6,*)'Subdivided 50 mm from the subsface layer & +! &and combined into underlying neighbor' - IF(msno <= 3 .and. dzsno(3) > 0.18)THEN + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN ! subdivided a new layer - msno = 4 - dzsno(3) = dzsno(3)/2. - swice(3) = swice(3)/2. - swliq(3) = swliq(3)/2. + msno = 4 + dzsno(3) = dzsno(3)/2. + swice(3) = swice(3)/2. + swliq(3) = swliq(3)/2. !Aerosol Fluxes (January 07, 2023) - mss_aerosol(3,:) = mss_aerosol(3,:)/2. + mss_aerosol(3,:) = mss_aerosol(3,:)/2. !Aerosol Fluxes (January 07, 2023) - dzsno(4) = dzsno(3) - swice(4) = swice(3) - swliq(4) = swliq(3) + dzsno(4) = dzsno(3) + swice(4) = swice(3) + swliq(4) = swliq(3) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(4,:) = mss_aerosol(3,:) + mss_aerosol(4,:) = mss_aerosol(3,:) !Aerosol Fluxes (January 07, 2023) - tsno(4) = tsno(3) + tsno(4) = tsno(3) - ENDIF + ENDIF ENDIF ENDIF IF(msno > 3)THEN IF(dzsno(3) > 0.11)THEN - drr = dzsno(3) - 0.11 - propor = drr/dzsno(3) - zwice = propor*swice(3) - zwliq = propor*swliq(3) + drr = dzsno(3) - 0.11 + propor = drr/dzsno(3) + zwice = propor*swice(3) + zwliq = propor*swliq(3) !Aerosol Fluxes (January 07, 2023) - z_mss_aerosol(:) = propor*mss_aerosol(3,:) + z_mss_aerosol(:) = propor*mss_aerosol(3,:) !Aerosol Fluxes (January 07, 2023) - propor = 0.11/dzsno(3) - swice(3) = propor*swice(3) - swliq(3) = propor*swliq(3) + propor = 0.11/dzsno(3) + swice(3) = propor*swice(3) + swliq(3) = propor*swliq(3) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(3,:) = propor*mss_aerosol(3,:) + mss_aerosol(3,:) = propor*mss_aerosol(3,:) !Aerosol Fluxes (January 07, 2023) - dzsno(3) = 0.11 + dzsno(3) = 0.11 - CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & - drr, zwliq, zwice, tsno(3)) + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & + drr, zwliq, zwice, tsno(3)) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(4,:) = z_mss_aerosol(:) + mss_aerosol(4,:) + mss_aerosol(4,:) = z_mss_aerosol(:) + mss_aerosol(4,:) !Aerosol Fluxes (January 07, 2023) -! write(6,*)'Subdivided 110 mm from the third Node & -! &and combined into underlying neighbor' +! write(6,*)'Subdivided 110 mm from the third Node & +! &and combined into underlying neighbor' - IF(msno <= 4 .and. dzsno(4) > 0.41)THEN + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN ! subdivided a new layer - msno = 5 - dzsno(4) = dzsno(4)/2. - swice(4) = swice(4)/2. - swliq(4) = swliq(4)/2. + msno = 5 + dzsno(4) = dzsno(4)/2. + swice(4) = swice(4)/2. + swliq(4) = swliq(4)/2. !Aerosol Fluxes (January 07, 2023) - mss_aerosol(4,:) = mss_aerosol(4,:)/2. + mss_aerosol(4,:) = mss_aerosol(4,:)/2. !Aerosol Fluxes (January 07, 2023) - dzsno(5) = dzsno(4) - swice(5) = swice(4) - swliq(5) = swliq(4) + dzsno(5) = dzsno(4) + swice(5) = swice(4) + swliq(5) = swliq(4) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(5,:) = mss_aerosol(4,:) + mss_aerosol(5,:) = mss_aerosol(4,:) !Aerosol Fluxes (January 07, 2023) - tsno(5) = tsno(4) + tsno(5) = tsno(4) - ENDIF + ENDIF ENDIF ENDIF IF(msno > 4)THEN IF(dzsno(4) > 0.23)THEN - drr = dzsno(4) - 0.23 - propor = drr/dzsno(4) - zwice = propor*swice(4) - zwliq = propor*swliq(4) + drr = dzsno(4) - 0.23 + propor = drr/dzsno(4) + zwice = propor*swice(4) + zwliq = propor*swliq(4) !Aerosol Fluxes (January 07, 2023) - z_mss_aerosol(:) = propor*mss_aerosol(4,:) + z_mss_aerosol(:) = propor*mss_aerosol(4,:) !Aerosol Fluxes (January 07, 2023) - propor = 0.23/dzsno(4) - swice(4) = propor*swice(4) - swliq(4) = propor*swliq(4) + propor = 0.23/dzsno(4) + swice(4) = propor*swice(4) + swliq(4) = propor*swliq(4) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(4,:) = propor*mss_aerosol(4,:) + mss_aerosol(4,:) = propor*mss_aerosol(4,:) !Aerosol Fluxes (January 07, 2023) - dzsno(4) = 0.23 + dzsno(4) = 0.23 - CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & - drr, zwliq, zwice, tsno(4)) + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & + drr, zwliq, zwice, tsno(4)) !Aerosol Fluxes (January 07, 2023) - mss_aerosol(5,:) = z_mss_aerosol(:) + mss_aerosol(5,:) + mss_aerosol(5,:) = z_mss_aerosol(:) + mss_aerosol(5,:) !Aerosol Fluxes (January 07, 2023) -! write(6,*)'Subdivided 230 mm from the fourth Node & -! 'and combined into underlying neighbor' +! write(6,*)'Subdivided 230 mm from the fourth Node & +! 'and combined into underlying neighbor' ENDIF ENDIF diff --git a/main/MOD_SnowSnicar.F90 b/main/MOD_SnowSnicar.F90 index 8ccc10d0..33f5f6e0 100644 --- a/main/MOD_SnowSnicar.F90 +++ b/main/MOD_SnowSnicar.F90 @@ -531,14 +531,14 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & flx_wgt(2) = 0.66628670195247_r8 flx_wgt(3) = 0.33371329804753_r8 ! Diffuse: - elseif (flg_slr_in == 2) THEN + ELSEIF (flg_slr_in == 2) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.77887652162877_r8 flx_wgt(3) = 0.22112347837123_r8 ENDIF ! 5-band weights - elseif(numrad_snw==5) THEN + ELSEIF(numrad_snw==5) THEN ! Direct: IF (flg_slr_in == 1) THEN flx_wgt(1) = 1._r8 @@ -547,7 +547,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & flx_wgt(4) = 0.12094898498813_r8 flx_wgt(5) = 0.20453448749347_r8 ! Diffuse: - elseif (flg_slr_in == 2) THEN + ELSEIF (flg_slr_in == 2) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.58581507618433_r8 flx_wgt(3) = 0.20156903770812_r8 @@ -586,14 +586,14 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & IF (bnd_idx == 1) THEN IF (flg_dover == 2) THEN APRX_TYP = 3 - elseif (flg_dover == 3) THEN + ELSEIF (flg_dover == 3) THEN APRX_TYP = 1 IF (coszen > 0.5_r8) THEN mu_not = mu_not - 0.02_r8 ELSE mu_not = mu_not + 0.02_r8 ENDIF - elseif (flg_dover == 4) THEN + ELSEIF (flg_dover == 4) THEN APRX_TYP = 3 ELSE APRX_TYP = 1 @@ -602,14 +602,14 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ELSE IF (flg_dover == 2) THEN APRX_TYP = 1 - elseif (flg_dover == 3) THEN + ELSEIF (flg_dover == 3) THEN APRX_TYP = 3 IF (coszen > 0.5_r8) THEN mu_not = mu_not - 0.02_r8 ELSE mu_not = mu_not + 0.02_r8 ENDIF - elseif (flg_dover == 4) THEN + ELSEIF (flg_dover == 4) THEN APRX_TYP = 1 ELSE APRX_TYP = 3 @@ -647,7 +647,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) ENDDO - elseif (flg_slr_in == 2) THEN + ELSEIF (flg_slr_in == 2) THEN DO i=snl_top,snl_btm,1 rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 ! snow optical properties (diffuse radiation) @@ -716,7 +716,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & IF (snw_rds_lcl(i) < 125) THEN tmp1 = snw_rds_lcl(i)/50 idx_bcint_icerds = nint(tmp1) - elseif (snw_rds_lcl(i) < 175) THEN + ELSEIF (snw_rds_lcl(i) < 175) THEN idx_bcint_icerds = 2 ELSE tmp1 = (snw_rds_lcl(i)/250)+2 @@ -827,7 +827,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ENDDO ! Quadrature - elseif (APRX_TYP==2) THEN + ELSEIF (APRX_TYP==2) THEN DO i=snl_top,snl_btm,1 gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2 gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2 @@ -837,7 +837,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ENDDO ! Hemispheric Mean - elseif (APRX_TYP==3) THEN + ELSEIF (APRX_TYP==3) THEN DO i=snl_top,snl_btm,1 gamma1(i) = 2 - (omega_star(i)*(1+g_star(i))) gamma2(i) = omega_star(i)*(1-g_star(i)) @@ -898,20 +898,20 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & D(i) = -e2(snl_top) E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top) - elseif(i==0) THEN + ELSEIF(i==0) THEN A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm)) B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm)) D(i) = 0 E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm)) - elseif(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) + ELSEIF(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) n=floor(i/2.0) A(i) = (e2(n)*e3(n))-(e4(n)*e1(n)) B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1)) D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1)) E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1))) - elseif(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl + ELSEIF(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl n=(i/2) A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1)) B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1)) @@ -1014,14 +1014,14 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Set conditions for redoing RT calculation IF ((trip == 1).and.(flg_dover == 1)) THEN flg_dover = 2 - elseif ((trip == 1).and.(flg_dover == 2)) THEN + ELSEIF ((trip == 1).and.(flg_dover == 2)) THEN flg_dover = 3 - elseif ((trip == 1).and.(flg_dover == 3)) THEN + ELSEIF ((trip == 1).and.(flg_dover == 3)) THEN flg_dover = 4 - elseif((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN flg_dover = 3 err_idx = err_idx + 1 - elseif((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN flg_dover = 0 #ifndef _OPENACC IF (p_is_master) THEN @@ -1115,7 +1115,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ENDDO ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo - elseif ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN albout(1) = albsfc(1) albout(2) = albsfc(2) @@ -1500,11 +1500,11 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! Define snow grain shape IF (trim(snow_shape) == 'sphere') THEN snw_shp_lcl(:) = snow_shape_sphere - elseif (trim(snow_shape) == 'spheroid') THEN + ELSEIF (trim(snow_shape) == 'spheroid') THEN snw_shp_lcl(:) = snow_shape_spheroid - elseif (trim(snow_shape) == 'hexagonal_plate') THEN + ELSEIF (trim(snow_shape) == 'hexagonal_plate') THEN snw_shp_lcl(:) = snow_shape_hexagonal_plate - elseif (trim(snow_shape) == 'koch_snowflake') THEN + ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN snw_shp_lcl(:) = snow_shape_koch_snowflake ELSE IF (p_is_master) THEN @@ -1516,17 +1516,17 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! Define atmospheric type IF (trim(snicar_atm_type) == 'default') THEN atm_type_index = atm_type_default - elseif (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN atm_type_index = atm_type_mid_latitude_winter - elseif (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN atm_type_index = atm_type_mid_latitude_summer - elseif (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN atm_type_index = atm_type_sub_Arctic_winter - elseif (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN atm_type_index = atm_type_sub_Arctic_summer - elseif (trim(snicar_atm_type) == 'summit_Greenland') THEN + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN atm_type_index = atm_type_summit_Greenland - elseif (trim(snicar_atm_type) == 'high_mountain') THEN + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE IF (p_is_master) THEN @@ -1644,14 +1644,14 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & flx_wgt(2) = 0.66628670195247_r8 flx_wgt(3) = 0.33371329804753_r8 ! Diffuse: - elseif (flg_slr_in == 2) THEN + ELSEIF (flg_slr_in == 2) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.77887652162877_r8 flx_wgt(3) = 0.22112347837123_r8 ENDIF ! 5-band weights - elseif(numrad_snw==5) THEN + ELSEIF(numrad_snw==5) THEN ! Direct: IF (flg_slr_in == 1) THEN IF (atm_type_index == atm_type_default) THEN @@ -1673,7 +1673,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ENDIF ! Diffuse: - elseif (flg_slr_in == 2) THEN + ELSEIF (flg_slr_in == 2) THEN IF (atm_type_index == atm_type_default) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.58581507618433_r8 @@ -1735,7 +1735,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) ENDDO - elseif (flg_slr_in == 2) THEN + ELSEIF (flg_slr_in == 2) THEN DO i=snl_top,snl_btm,1 rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 ! snow optical properties (diffuse radiation) @@ -1762,7 +1762,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ENDIF g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) - elseif(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate + ELSEIF(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate diam_ice = 2._r8*snw_rds_lcl(i) IF(snw_fs_lcl(i) == 0._r8) THEN fs_hex0 = 0.788_r8 @@ -1777,7 +1777,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ENDIF g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) - elseif(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake + ELSEIF(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 IF(snw_fs_lcl(i) == 0._r8) THEN fs_koch = 0.712_r8 @@ -1799,20 +1799,20 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & IF(bnd_idx == 1) THEN g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) - elseif(bnd_idx == 2) THEN + ELSEIF(bnd_idx == 2) THEN g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) - elseif(bnd_idx == 3) THEN + ELSEIF(bnd_idx == 3) THEN g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& +g_ice_Cg_tmp(2) gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& +gg_ice_F07_tmp(2) - elseif(bnd_idx == 4) THEN + ELSEIF(bnd_idx == 4) THEN g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& +g_ice_Cg_tmp(2) gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& +gg_ice_F07_tmp(2) - elseif(bnd_idx == 5) THEN + ELSEIF(bnd_idx == 5) THEN g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& +g_ice_Cg_tmp(5) gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& @@ -1889,7 +1889,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & IF (snw_rds_lcl(i) < 125) THEN tmp1 = snw_rds_lcl(i)/50 idx_bcint_icerds = nint(tmp1) - elseif (snw_rds_lcl(i) < 175) THEN + ELSEIF (snw_rds_lcl(i) < 175) THEN idx_bcint_icerds = 2 ELSE tmp1 = (snw_rds_lcl(i)/250)+2 @@ -2379,7 +2379,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ENDIF ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo - elseif ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN albout(1) = albsfc(1) albout(2) = albsfc(2) @@ -2602,12 +2602,12 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz , & #ifdef MODAL_AER IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN dr_fresh = 0.0_r8 - ELSE IF ( dr_fresh < 0.0_r8 ) THEN + ELSEIF ( dr_fresh < 0.0_r8 ) THEN IF (p_is_master) THEN write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min CALL abort ENDIF - END IF + ENDIF dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) #else @@ -2687,7 +2687,7 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz , & IF (snw_rds(i) > snw_rds_max) THEN snw_rds(i) = snw_rds_max - END IF + ENDIF ! set top layer variables for history files IF (i == snl_top) THEN @@ -2705,7 +2705,7 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz , & IF (snl >= 0 .and. h2osno > 0._r8) THEN snw_rds(0) = snw_rds_min - END IF + ENDIF ! END associate @@ -2731,19 +2731,19 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) atm_type_index = atm_type_default ! Define atmospheric type IF (trim(snicar_atm_type) == 'default') THEN - atm_type_index = atm_type_default - elseif (trim(snicar_atm_type) == 'mid-latitude_winter') THEN - atm_type_index = atm_type_mid_latitude_winter - elseif (trim(snicar_atm_type) == 'mid-latitude_summer') THEN - atm_type_index = atm_type_mid_latitude_summer - elseif (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN - atm_type_index = atm_type_sub_Arctic_winter - elseif (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN - atm_type_index = atm_type_sub_Arctic_summer - elseif (trim(snicar_atm_type) == 'summit_Greenland') THEN - atm_type_index = atm_type_summit_Greenland - elseif (trim(snicar_atm_type) == 'high_mountain') THEN - atm_type_index = atm_type_high_mountain + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain ELSE IF (p_is_master) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type @@ -2975,19 +2975,19 @@ real(r8) FUNCTION FreshSnowRadius (forc_t) real(r8) :: gs_max ! maximum value IF ( fresh_snw_rds_max <= snw_rds_min )THEN - FreshSnowRadius = snw_rds_min + FreshSnowRadius = snw_rds_min ELSE - gs_max = fresh_snw_rds_max - - IF (forc_t < tmin) THEN - FreshSnowRadius = gs_min - ELSE IF (forc_t > tmax) THEN - FreshSnowRadius = gs_max - ELSE - FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & - (forc_t-tmin)/(tmax-tmin)*gs_max - END IF - END IF + gs_max = fresh_snw_rds_max + + IF (forc_t < tmin) THEN + FreshSnowRadius = gs_min + ELSEIF (forc_t > tmax) THEN + FreshSnowRadius = gs_max + ELSE + FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & + (forc_t-tmin)/(tmax-tmin)*gs_max + ENDIF + ENDIF END FUNCTION FreshSnowRadius diff --git a/main/MOD_Thermal.F90 b/main/MOD_Thermal.F90 index eed29f0c..52604c49 100644 --- a/main/MOD_Thermal.F90 +++ b/main/MOD_Thermal.F90 @@ -645,7 +645,7 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& extkd ,forc_hgt_u ,forc_hgt_t,forc_hgt_q ,forc_us ,& forc_vs ,thm ,th ,thv ,forc_q ,& forc_psrf ,forc_rhoair,parsun ,parsha ,sabv ,& - frl ,fsun ,thermk ,rstfacsun_out,rstfacsha_out,& + frl ,fsun ,thermk,rstfacsun_out,rstfacsha_out,& gssun_out ,gssha_out ,forc_po2m ,forc_pco2m ,z0h_g ,& obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& sigf ,etrc ,t_grnd ,qg,rss ,& @@ -784,12 +784,14 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& extkd_p(i) ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& forc_vs ,thm ,th ,thv ,forc_q ,& forc_psrf ,forc_rhoair,parsun_p(i),parsha_p(i),sabv_p(i) ,& - frl ,fsun_p(i) ,thermk_p(i),rstfacsun_p(i),rstfacsha_p(i),& + !TODO + frl, fsun_p(i) ,thermk_p(i),rstfacsun_p(i),rstfacsha_p(i),& gssun_p(i) ,gssha_p(i) ,forc_po2m ,forc_pco2m ,z0h_g ,& obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& sigf_p(i) ,etrc_p(i) ,t_grnd ,qg,rss ,& t_soil ,t_snow ,q_soil ,q_snow ,& dqgdT ,& + !TODO emg ,tleaf_p(i) ,ldew_p(i) ,ldew_rain_p(i),ldew_snow_p(i),& taux_p(i) ,tauy_p(i) ,& fseng_p(i),fseng_soil_p(i),fseng_snow_p(i), & diff --git a/main/MOD_Vars_TimeInvariants.F90 b/main/MOD_Vars_TimeInvariants.F90 index 6a59a61b..f73e823c 100644 --- a/main/MOD_Vars_TimeInvariants.F90 +++ b/main/MOD_Vars_TimeInvariants.F90 @@ -573,35 +573,35 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) ENDIF #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) then + if (p_is_master) then #ifndef VectorInOneFile - CALL ncio_create_file (file_restart) -#endif - - CALL ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] - CALL ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] - CALL ncio_write_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] - CALL ncio_write_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew - CALL ncio_write_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table - CALL ncio_write_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T - CALL ncio_write_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 - CALL ncio_write_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow - CALL ncio_write_serial (file_restart, 'wimp ', wimp ) ! water impremeable if porosity less than wimp - CALL ncio_write_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) - CALL ncio_write_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm - CALL ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) - CALL ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] - CALL ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow - CALL ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) - - END if + CALL ncio_create_file (file_restart) +#endif + + CALL ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_write_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_write_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + CALL ncio_write_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_write_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_write_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_write_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_write_serial (file_restart, 'wimp ', wimp ) ! water impremeable if porosity less than wimp + CALL ncio_write_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_write_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + + END if #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) diff --git a/main/URBAN/MOD_Urban_Flux.F90 b/main/URBAN/MOD_Urban_Flux.F90 index 1231901e..6052e938 100644 --- a/main/URBAN/MOD_Urban_Flux.F90 +++ b/main/URBAN/MOD_Urban_Flux.F90 @@ -2352,9 +2352,11 @@ SUBROUTINE UrbanVegFlux ( & - fsenl - hvap*fevpl #if(defined CLMDEBUG) - IF (abs(err) .gt. .2) & + IF (abs(err) .gt. .2) THEN write(6,*) 'energy imbalance in UrbanVegFlux.F90', & i,it-1,err,sabv,irab,fsenl,hvap*fevpl + CALL CoLM_stop() + ENDIF #endif diff --git a/main/URBAN/MOD_Urban_Thermal.F90 b/main/URBAN/MOD_Urban_Thermal.F90 index 3cfe0976..9a6b73db 100644 --- a/main/URBAN/MOD_Urban_Thermal.F90 +++ b/main/URBAN/MOD_Urban_Thermal.F90 @@ -104,9 +104,10 @@ SUBROUTINE UrbanTHERMAL ( & !======================================================================= USE MOD_Precision + USE MOD_SPMD_Task USE MOD_Vars_Global USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& - stefnc,denice,tfrz,vonkar,grav + stefnc,denice,tfrz,vonkar,grav USE MOD_Urban_Shortwave USE MOD_Urban_Longwave USE MOD_Urban_GroundFlux @@ -1286,6 +1287,7 @@ SUBROUTINE UrbanTHERMAL ( & IF (olrg < 0) THEN !fordebug print*, ipatch, olrg write(6,*) ipatch,sabv,sabg,forc_frl,olrg,fsenl,fseng,hvap*fevpl,lfevpa + CALL CoLM_stop() ENDIF ! radiative temperature diff --git a/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 b/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 index bdea1f42..599d63fb 100644 --- a/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 +++ b/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 @@ -74,8 +74,8 @@ SUBROUTINE allocate_1D_UrbanFluxes allocate (lfevp_gimp (numurban)) ; lfevp_gimp (:) = spval allocate (lfevp_gper (numurban)) ; lfevp_gper (:) = spval allocate (lfevp_urbl (numurban)) ; lfevp_urbl (:) = spval - ENDIF - ENDIF + ENDIF + ENDIF END SUBROUTINE allocate_1D_UrbanFluxes @@ -141,8 +141,8 @@ SUBROUTINE set_1D_UrbanFluxes(Values, Nan) lfevp_gimp (:) = Values lfevp_gper (:) = Values lfevp_urbl (:) = Values - ENDIF - ENDIF + ENDIF + ENDIF END SUBROUTINE set_1D_UrbanFluxes