From baf218e95538ee0848a175b6b99d2230681dd0b2 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Wed, 20 Apr 2022 17:50:12 -0400 Subject: [PATCH 01/21] minor bug fixes and cleanup: - reinstated "source g5_modules" command within SBATCH job scripts created by make_bcs - renamed environment variables for clarification - removed obsolete "cd" and "SBATCH --chdir" --- .../Utils/Raster/make_bcs | 52 ++++++++----------- 1 file changed, 22 insertions(+), 30 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs index 20171d2e6..e21883729 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs @@ -78,7 +78,7 @@ set BOLD = "\033[1m" ####################################################################### ####################################################################### -set pwd = `pwd` +set bin_dir = `pwd` # make_bcs must be run from install/bin directory set C1 = $RED set C2 = $BLUE @@ -359,9 +359,9 @@ foreach orslv ($orslvs) set HOSTNAME = `hostname | rev | cut -c3- | rev` if ( $HOSTNAME == discover ) then - set l_data = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ + set input_dir = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ else - set l_data = /nobackup/gmao_SIteam/ModelData/l_data/LandBCs_files_for_mkCatchParam/V001/ + set input_dir = /nobackup/gmao_SIteam/ModelData/l_data/LandBCs_files_for_mkCatchParam/V001/ endif @@ -372,9 +372,9 @@ if ( $orslv == O1 | $orslv == T2 | $orslv == T3 | $orslv == T4 | \ # ------------------------------------------------------------------------------------------------- if ( $lbcsv == F25 | $lbcsv == GM4 | $lbcsv == ICA ) then - set GLOBAL_CATCH_DATA = ${l_data}/global.cat_id.catch.DL + set GLOBAL_CATCH_DATA = ${input_dir}/global.cat_id.catch.DL else - set GLOBAL_CATCH_DATA = ${l_data}/GEOS5_10arcsec_mask_freshwater-lakes.nc + set GLOBAL_CATCH_DATA = ${input_dir}/GEOS5_10arcsec_mask_freshwater-lakes.nc endif @@ -384,9 +384,9 @@ else if ( $orslv == O2 | $orslv == O3 | $orslv == CS ) then # -------------------------------------------------------------------------------------------------------------- if ( $lbcsv == F25 | $lbcsv == GM4 | $lbcsv == ICA ) then - set GLOBAL_CATCH_DATA = ${l_data}/global.cat_id.catch.GreatLakesCaspian_Updated.DL + set GLOBAL_CATCH_DATA = ${input_dir}/global.cat_id.catch.GreatLakesCaspian_Updated.DL else - set GLOBAL_CATCH_DATA = ${l_data}/GEOS5_10arcsec_mask.nc + set GLOBAL_CATCH_DATA = ${input_dir}/GEOS5_10arcsec_mask.nc endif else @@ -397,7 +397,7 @@ else endif if($HRCODE == m1 | $HRCODE == m3 | $HRCODE == m9 | $HRCODE == m36 | $HRCODE == m25) then - set GLOBAL_CATCH_DATA = ${l_data}/GEOS5_10arcsec_mask.nc + set GLOBAL_CATCH_DATA = ${input_dir}/GEOS5_10arcsec_mask.nc endif set MASKFILE = `echo ${GLOBAL_CATCH_DATA} | rev | cut -d / -f1 | rev ` @@ -713,14 +713,12 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/360x200 data/MOM5/360x200 ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/720x410 data/MOM5/720x410 @@ -729,7 +727,7 @@ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/72x36 data/MOM6/ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/1440x1080 data/MOM6/1440x1080 cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ @@ -902,14 +900,12 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=1 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/360x200 data/MOM5/360x200 ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/720x410 data/MOM5/720x410 @@ -918,7 +914,7 @@ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/72x36 data/MOM6/ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/1440x1080 data/MOM6/1440x1080 cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ @@ -970,12 +966,11 @@ cat << _EOF_ > $BCJOB-2 #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME-2.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR + +source bin/g5_modules setenv MASKFILE $MASKFILE limit stacksize unlimited @@ -1101,14 +1096,12 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/360x200 data/MOM5/360x200 ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/720x410 data/MOM5/720x410 @@ -1117,7 +1110,7 @@ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/72x36 data/MOM6/ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/1440x1080 data/MOM6/1440x1080 cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ @@ -1311,16 +1304,15 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ limit stacksize unlimited if ( $EVERSION == EASEv2 ) then From 92384197792d2eebb99257257a7d22d41f30c454 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Thu, 28 Apr 2022 18:22:11 -0400 Subject: [PATCH 02/21] substantial cleanup of subroutine create_model_para_woesten(); added comments throughout --- .../Utils/Raster/rmTinyCatchParaMod.F90 | 665 +++++++++++------- 1 file changed, 400 insertions(+), 265 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 index 300ba87e2..7417cf8de 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 @@ -37,7 +37,7 @@ module rmTinyCatchParaMod public create_soil_types_files,compute_mosaic_veg_types public cti_stat_file, create_model_para_woesten public create_model_para, modis_lai,regridraster,regridrasterreal - public i_raster, j_raster,regridraster1,regridraster2,n_SoilClasses,gnu,zks + public i_raster, j_raster,regridraster1,regridraster2,n_SoilClasses,zks public mineral_perc, process_gswp2_veg,center_pix, soil_class public tgen, sat_param,REFORMAT_VEGFILES,base_param,ts_param public :: Get_MidTime, Time_Interp_Fac, compute_stats, c_data @@ -48,7 +48,7 @@ module rmTinyCatchParaMod character*8, public, save :: LAIBCS = 'MODGEO' character*4, public, save :: SOILBCS = 'HWSD' character*6, public, save :: MODALB = 'MODIS2' - REAL, save :: GNU = 1.0 + REAL, public, save :: GNU = 1.0 type :: mineral_perc real :: clay_perc @@ -62,7 +62,8 @@ SUBROUTINE init_bcs_config (LBSV) implicit none - character(*), intent (in) :: LBSV + character(*), intent (in) :: LBSV ! LBSV = land BCs version (?) + ! LAIBCS: Choice of LAI data set. DEFAULT : MODGEO ! GLASSA : 8-day AVHRR climatology from the period 1981-2017 on 7200x3600 grid ! GLASSM : 8-day MODIS climatology from the period 2000-2017 on 7200x3600 grid @@ -3503,10 +3504,11 @@ SUBROUTINE create_model_para_woesten (Maskfile) atile_sand,atile_clay, tile_lon, tile_lat, grav_vec, soc_vec,& poc_vec,a_sand_surf,a_clay_surf,wpwet_surf,poros_surf, pmap - real, allocatable, dimension (:,:) :: good_clay, good_sand - integer, allocatable, dimension (:,:) :: tile_add, tile_pick - type (mineral_perc) :: min_percs - integer :: CF1, CF2, CF3, CF4 +!obsolete20220428 real, allocatable, dimension (:,:) :: good_clay, good_sand +!obsolete20220428 integer, allocatable, dimension (:,:) :: tile_add, tile_pick +!obsolete20220428 type (mineral_perc) :: min_percs +!obsolete20220428 integer :: CF1, CF2, CF3, CF4 + integer i,j,n,k, tindex1,pfaf1,nbcatch integer soil_gswp real meanlu,stdev,minlu,maxlu,coesk,rzdep @@ -3591,7 +3593,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) endif open (11, file=trim(fname), form='formatted',status='old', & action = 'read') - read (11,'(a)')fout + read (11,'(a)')fout ! read header line + losfile =trim(c_data)//'/Woesten_SoilParam/loss_pd_top/loss_perday_rz1m_' allocate (a_sand (1:n_SoilClasses)) @@ -3604,17 +3607,17 @@ SUBROUTINE create_model_para_woesten (Maskfile) allocate (gfrc (1:nwt,1:nrz,1:n_SoilClasses)) do n =1,n_SoilClasses + + ! read sand/clay/orgC for class n defined in SoilClasses-SoilHyd-TauParam.* + read (11,'(4f7.3)')a_sand(n),a_clay(n),a_silt(n),a_oc(n) write (fout,'(i2.2,i2.2,i4.4)')nint(a_sand(n)),nint(a_clay(n)),nint(100*a_oc(n)) - if(n == n_SoilClasses) then - if(use_PEATMAP) then - open (120,file=trim(losfile)//trim(fout)//'.peat', & - form='formatted',status='old') - else - open (120,file=trim(losfile)//trim(fout), & + ! open and read loss parameter file for class n (defined through sand/clay/orgC) + + if(n == n_SoilClasses .and. use_PEATMAP) then + open (120,file=trim(losfile)//trim(fout)//'.peat', & form='formatted',status='old') - endif else open (120,file=trim(losfile)//trim(fout), & form='formatted',status='old') @@ -3635,6 +3638,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) close (11,status='keep') deallocate (a_sand,a_silt,a_clay,a_oc) + ! open files for *reading* + fname='clsm/soil_param.first' open (10,file=fname,action='read', & form='formatted',status='old') @@ -3647,6 +3652,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) open (12,file=fname,action='read', & form='formatted',status='old') + ! open files for *writing* + fout='clsm/ar.new' open (20,file=fout,action='write', & form='formatted',status='unknown') @@ -3678,8 +3685,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) open (42,file=fout,action='write', & form='formatted',status='unknown') - read (11,*)nbcatch - read (12,*)nbcatch + read (11,*)nbcatch ! read header line (number of tiles) -- cti_stats.dat + read (12,*)nbcatch ! read header line (number of tiles) -- catchment.def allocate (tile_lon(1:nbcatch)) allocate (tile_lat(1:nbcatch)) @@ -3732,19 +3739,30 @@ SUBROUTINE create_model_para_woesten (Maskfile) allocate (wpwet_surf (1:nbcatch)) allocate (poros_surf (1:nbcatch)) allocate (pmap (1:nbcatch)) - allocate (good_clay (1:100,4)) - allocate (good_sand (1:100,4)) - allocate (tile_add (1:100,4)) - allocate (tile_pick (1:100,4)) - tile_add = 0 - tile_pick= 0 - good_clay =0. - good_sand =0. + +!obsolete20220428 allocate (good_clay (1:100,4)) +!obsolete20220428 allocate (good_sand (1:100,4)) +!obsolete20220428 allocate (tile_add (1:100,4)) +!obsolete20220428 allocate (tile_pick (1:100,4)) +!obsolete20220428 tile_add = 0 +!obsolete20220428 tile_pick= 0 +!obsolete20220428 good_clay =0. +!obsolete20220428 good_sand =0. do n=1,nbcatch + + ! read cti_stats.dat + read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev & ,minlu,maxlu,coesk + ! read soil_param.first + ! + ! WARNING: Immediately after the present do loop, BEE, COND, POROS, PSIS, WPWET, and + ! soildepth will be read again (and thus overwritten) with the values from + ! the catch_params.nc4 file. It is unclear if the values in soil_param.first + ! and catch_params.nc4 differ. See comments below. + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & @@ -3755,6 +3773,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) stop endif + ! read catchment.def + read (12,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat tile_lon(n) = (minlon + maxlon)/2. tile_lat(n) = (minlat + maxlat)/2. @@ -3787,11 +3807,26 @@ SUBROUTINE create_model_para_woesten (Maskfile) minlu,maxlu stop endif - END DO + END DO ! n=1,nbcatch inquire(file='clsm/catch_params.nc4', exist=file_exists) if(file_exists) then + + ! Read BEE, COND, POROS, PSIS, WPWET, and soildepth from nc4 file. + ! It is unclear if parameters in nc4 file differ from those in soil_param.first, which were read + ! in the do loop just above. + ! Probably, the parameters differ by roundoff because soil_param.first is an ASCII file and + ! catch_params.nc4 is a netcdf file. Consequently, the parameters from the nc4 file are used + ! in the calculation of the ar.new, bf.dat, and ts.dat parameters, which comes next. + ! To maintain consistency between the parameters in soil_param.first and soil_param.dat where + ! no changes are needed, soil_param.first needs to be read again below (so as to overwrite + ! the values from the nc4 file). + ! Why the parameters from the nc4 file are read here in the first place remains a mystery. + ! Removing this read, however, will (almost certainly) result in non-zero-diff changes + ! for existing bcs datasets. + ! - reichle, 28 April 2022 + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) allocate (parms4file (1:nbcatch, 1:25)) status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) @@ -3808,7 +3843,7 @@ SUBROUTINE create_model_para_woesten (Maskfile) parms4file (:,25) = soildepth(:) endif - rewind(10) + rewind(10) ! soil_param.first (so soil_param.first can be read again below...) allocate(low_ind(n_threads)) allocate(upp_ind(n_threads)) @@ -3849,8 +3884,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & ST,AC,COESKEW) -!c Areal fractioning parameters - + ! compute areal fractioning parameters (ar.new) + CALL SAT_PARAM( & BEE(n),PSIS(n),POROS(n),COND(n), & WPWET(n), ST, AC, COESKEW,n, & @@ -3861,6 +3896,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) taberr1(n),taberr2(n),taberr3(n),taberr4(n), & normerr1(n),normerr2(n),normerr3(n),normerr4(n)) + ! compute base flow parameters (bf.dat) + CALL BASE_PARAM( & BEE(n),PSIS(n),POROS(n),COND(n), & ST, AC, & @@ -3874,6 +3911,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) rzexcn (:,:) = grzexcn (:,:,soil_class_com(n)) frc (:,:) = gfrc (:,:,soil_class_com(n)) + ! compute time scale parameters (rzexc-catdef) (ts.dat) + CALL TS_PARAM( & BEE(n),PSIS(n),POROS(n), & ST, AC, & @@ -3881,10 +3920,9 @@ SUBROUTINE create_model_para_woesten (Maskfile) tsa1(n),tsa2(n),tsb1(n),tsb2(n) & ) - if(soil_class_com(n) == 253) then + if(soil_class_com(n) == 253 .and. use_PEATMAP) then ! Michel Bechtold paper - PEATCLSM_fitting_CLSM_params.R produced these data values. - if(use_PEATMAP) then ars1(n) = -7.9514018e-03 ars2(n) = 6.2297356e-02 @@ -3907,182 +3945,338 @@ SUBROUTINE create_model_para_woesten (Maskfile) tsb1(n) = -3.700285e-03 tsb2(n) = -2.392484e-03 - endif endif END DO END DO !$OMP ENDPARALLELDO - CF1 =0 - CF2 =0 - CF3 =0 - CF4 =0 - - DO n=1,nbcatch - - if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then - - if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then - group=1 - else if ((soil_class_com(n) > 84).and.(soil_class_com(n)<=168)) then - group=2 - else if ((soil_class_com(n) >168).and.(soil_class_com(n)< N_SoilClasses)) then - group=3 - else - group=4 - endif - - min_percs%clay_perc = atile_clay(n) - min_percs%sand_perc = atile_sand(n) - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - if(tile_pick(soil_class (min_percs),group) == 0) then - tile_pick(soil_class (min_percs),group) = n - - select case (group) - - case (1) - - CF1 = CF1 + 1 - good_clay (CF1,group) = atile_clay(n) - good_sand (CF1,group) = atile_sand(n) - tile_add (CF1,group) = n - - case (2) - CF2 = CF2 + 1 - good_clay (CF2,group) = atile_clay(n) - good_sand (CF2,group) = atile_sand(n) - tile_add (CF2,group) = n - - case (3) - CF3 = CF3 + 1 - good_clay (CF3,group) = atile_clay(n) - good_sand (CF3,group) = atile_sand(n) - tile_add (CF3,group) = n - - case (4) - CF4 = CF4 + 1 - good_clay (CF4,group) = atile_clay(n) - good_sand (CF4,group) = atile_sand(n) - tile_add (CF4,group) = n - - end select - endif - endif - END DO - +! This code block is obsolete because it was only needed if preserve_soiltype==.true, but +! preserve_soiltype was hardwired to .false. above. +! -reichle, 28 April 2022 +! +!obsolete20220428 CF1 =0 +!obsolete20220428 CF2 =0 +!obsolete20220428 CF3 =0 +!obsolete20220428 CF4 =0 +!obsolete20220428 +!obsolete20220428 DO n=1,nbcatch +!obsolete20220428 +!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then +!obsolete20220428 +!obsolete20220428 ! determine organic carbon class ("group") from soil class +!obsolete20220428 +!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then +!obsolete20220428 group=1 +!obsolete20220428 else if ((soil_class_com(n) > 84).and.(soil_class_com(n)<=168)) then +!obsolete20220428 group=2 +!obsolete20220428 else if ((soil_class_com(n) >168).and.(soil_class_com(n)< N_SoilClasses)) then +!obsolete20220428 group=3 +!obsolete20220428 else +!obsolete20220428 group=4 ! peat +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 ! assemble scalar structure that holds mineral percentages of tile n +!obsolete20220428 +!obsolete20220428 min_percs%clay_perc = atile_clay(n) +!obsolete20220428 min_percs%sand_perc = atile_sand(n) +!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc +!obsolete20220428 +!obsolete20220428 ! "soil_class" is an integer function (defined below) that assigns +!obsolete20220428 ! an integer soil class [1-100] for a given mineral percentage triplet +!obsolete20220428 +!obsolete20220428 ! "tile_pick" contains the number (ID) n of a sample tile for each +!obsolete20220428 ! soil class +!obsolete20220428 +!obsolete20220428 if(tile_pick(soil_class (min_percs),group) == 0) then +!obsolete20220428 +!obsolete20220428 ! assign tile n as the sample tile for its soil class in "tile_pick" +!obsolete20220428 +!obsolete20220428 tile_pick(soil_class (min_percs),group) = n +!obsolete20220428 +!obsolete20220428 ! Assign sand/clay from tile n to "good_clay" and "good_sand" for its class???? +!obsolete20220428 ! Why is "good_sand" dimension (100,4) when CF[x] seems to count the +!obsolete20220428 ! number of tiles within each organic carbon subclass ("group")?? +!obsolete20220428 +!obsolete20220428 select case (group) +!obsolete20220428 +!obsolete20220428 case (1) +!obsolete20220428 +!obsolete20220428 CF1 = CF1 + 1 +!obsolete20220428 good_clay (CF1,group) = atile_clay(n) +!obsolete20220428 good_sand (CF1,group) = atile_sand(n) +!obsolete20220428 tile_add (CF1,group) = n +!obsolete20220428 +!obsolete20220428 case (2) +!obsolete20220428 CF2 = CF2 + 1 +!obsolete20220428 good_clay (CF2,group) = atile_clay(n) +!obsolete20220428 good_sand (CF2,group) = atile_sand(n) +!obsolete20220428 tile_add (CF2,group) = n +!obsolete20220428 +!obsolete20220428 case (3) +!obsolete20220428 CF3 = CF3 + 1 +!obsolete20220428 good_clay (CF3,group) = atile_clay(n) +!obsolete20220428 good_sand (CF3,group) = atile_sand(n) +!obsolete20220428 tile_add (CF3,group) = n +!obsolete20220428 +!obsolete20220428 case (4) +!obsolete20220428 CF4 = CF4 + 1 +!obsolete20220428 good_clay (CF4,group) = atile_clay(n) +!obsolete20220428 good_sand (CF4,group) = atile_sand(n) +!obsolete20220428 tile_add (CF4,group) = n +!obsolete20220428 +!obsolete20220428 end select +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 endif ! (ars1(n).ne.9999.).and.(arw1(n).ne.9999.) +!obsolete20220428 +!obsolete20220428 END DO ! n=1,nbcatch + + ! ---------------------------------------------------------------------------------------- + ! + ! write ar.new, bf.dat, ts.dat, and soil_param.dat + DO n=1,nbcatch - read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + + ! Read soil_param.first again...; this is (almost certainly) needed to maintain consistency + ! between soil_param.first and soil_param.dat, see comments above. + + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & grav_vec(n),soc_vec(n),poc_vec(n), & a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) , & wpwet_surf(n),poros_surf(n), pmap(n) - if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n) - - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & - wpwet_surf(n),poros_surf(n), pmap(n) - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(n) - parms4file (n, 2) = ara2(n) - parms4file (n, 3) = ara3(n) - parms4file (n, 4) = ara4(n) - parms4file (n, 5) = ars1(n) - parms4file (n, 6) = ars2(n) - parms4file (n, 7) = ars3(n) - parms4file (n, 8) = arw1(n) - parms4file (n, 9) = arw2(n) - parms4file (n,10) = arw3(n) - parms4file (n,11) = arw4(n) - parms4file (n,13) = bf1(n) - parms4file (n,14) = bf2(n) - parms4file (n,15) = bf3(n) - parms4file (n,17) = gnu - parms4file (n,20) = tsa1(n) - parms4file (n,21) = tsa2(n) - parms4file (n,22) = tsb1(n) - parms4file (n,23) = tsb2(n) - endif - else - if(preserve_soiltype) then - if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then - group=1 - else if ((soil_class_com(n)> 84).and.(soil_class_com(n)<=168)) then - group=2 - else if ((soil_class_com(n)> 168).and.(soil_class_com(n)< N_SoilClasses)) then - group=3 - else - group=4 - endif - - min_percs%clay_perc = atile_clay(n) - min_percs%sand_perc = atile_sand(n) - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - if(tile_pick(soil_class (min_percs),group) > 0) then - k = tile_pick(soil_class (min_percs),group) - - else - select case (group) - - case (1) - j = center_pix (good_clay(1:CF1,group),good_sand(1:CF1,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - case (2) - j = center_pix (good_clay(1:CF2,group),good_sand(1:CF2,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - case (3) - j = center_pix (good_clay(1:CF3,group),good_sand(1:CF3,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - case (4) - j = center_pix (good_clay(1:CF4,group),good_sand(1:CF4,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - end select - print *,'NO Similar SoilClass :',soil_class (min_percs),group,n,k - - endif - if (error_file) then - write (41,*)n,k - ! write (41,*)tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - ! BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) - ! write (41,*)tindex2(k),pfaf2(k),soil_class_top,soil_class_com(k), & - ! BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) - endif - - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) +! This code block was obsolete because only one set of write statements is needed/desired. +! Repeating near-verbatim copies of write statements was bad coding practice. +! - reichle, 28 April 2022 +! +!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then +!obsolete20220428 +!obsolete20220428 ! nominal case, all parameter values are good +!obsolete20220428 +!obsolete20220428 ! write ar.new +!obsolete20220428 +!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & +!obsolete20220428 tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 ars1(n),ars2(n),ars3(n), & +!obsolete20220428 ara1(n),ara2(n),ara3(n),ara4(n), & +!obsolete20220428 arw1(n),arw2(n),arw3(n),arw4(n) +!obsolete20220428 +!obsolete20220428 ! write bf.dat +!obsolete20220428 +!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) +!obsolete20220428 +!obsolete20220428 ! write ts.dat +!obsolete20220428 +!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 tsa1(n),tsa2(n),tsb1(n),tsb2(n) +!obsolete20220428 +!obsolete20220428 ! write soil_param.dat +!obsolete20220428 +!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & +!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & +!obsolete20220428 BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & +!obsolete20220428 grav_vec(n),soc_vec(n),poc_vec(n), & +!obsolete20220428 a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & +!obsolete20220428 wpwet_surf(n),poros_surf(n), pmap(n) +!obsolete20220428 +!obsolete20220428 if (allocated (parms4file)) then +!obsolete20220428 parms4file (n, 1) = ara1(n) +!obsolete20220428 parms4file (n, 2) = ara2(n) +!obsolete20220428 parms4file (n, 3) = ara3(n) +!obsolete20220428 parms4file (n, 4) = ara4(n) +!obsolete20220428 parms4file (n, 5) = ars1(n) +!obsolete20220428 parms4file (n, 6) = ars2(n) +!obsolete20220428 parms4file (n, 7) = ars3(n) +!obsolete20220428 parms4file (n, 8) = arw1(n) +!obsolete20220428 parms4file (n, 9) = arw2(n) +!obsolete20220428 parms4file (n,10) = arw3(n) +!obsolete20220428 parms4file (n,11) = arw4(n) +!obsolete20220428 parms4file (n,13) = bf1(n) +!obsolete20220428 parms4file (n,14) = bf2(n) +!obsolete20220428 parms4file (n,15) = bf3(n) +!obsolete20220428 parms4file (n,17) = gnu +!obsolete20220428 parms4file (n,20) = tsa1(n) +!obsolete20220428 parms4file (n,21) = tsa2(n) +!obsolete20220428 parms4file (n,22) = tsb1(n) +!obsolete20220428 parms4file (n,23) = tsb2(n) +!obsolete20220428 endif + + +! This code block is obsolete because it was only needed if preserve_soiltype==.true, but +! preserve_soiltype was hardwired to .false. above. +! -reichle, 28 April 2022 +! +!obsolete20220428 else ! (ars1(n).ne.9999.) .or. (arw1(n)==9999.) +!obsolete20220428 +!obsolete20220428 ! exception, some parameter values are no-data +!obsolete20220428 +!obsolete20220428 if(preserve_soiltype) then +!obsolete20220428 +!obsolete20220428 ! look for a tile with a similar soil class +!obsolete20220428 +!obsolete20220428 ! NOTE: preserve_soiltype=.false. hardwired as of 28 Apr 2022 +!obsolete20220428 +!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then +!obsolete20220428 group=1 +!obsolete20220428 else if ((soil_class_com(n)> 84).and.(soil_class_com(n)<=168)) then +!obsolete20220428 group=2 +!obsolete20220428 else if ((soil_class_com(n)> 168).and.(soil_class_com(n)< N_SoilClasses)) then +!obsolete20220428 group=3 +!obsolete20220428 else +!obsolete20220428 group=4 +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 min_percs%clay_perc = atile_clay(n) +!obsolete20220428 min_percs%sand_perc = atile_sand(n) +!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc +!obsolete20220428 +!obsolete20220428 if(tile_pick(soil_class (min_percs),group) > 0) then +!obsolete20220428 +!obsolete20220428 k = tile_pick(soil_class (min_percs),group) +!obsolete20220428 +!obsolete20220428 else +!obsolete20220428 +!obsolete20220428 select case (group) +!obsolete20220428 +!obsolete20220428 case (1) +!obsolete20220428 j = center_pix (good_clay(1:CF1,group),good_sand(1:CF1,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 case (2) +!obsolete20220428 j = center_pix (good_clay(1:CF2,group),good_sand(1:CF2,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 case (3) +!obsolete20220428 j = center_pix (good_clay(1:CF3,group),good_sand(1:CF3,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 case (4) +!obsolete20220428 j = center_pix (good_clay(1:CF4,group),good_sand(1:CF4,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 end select +!obsolete20220428 print *,'NO Similar SoilClass :',soil_class (min_percs),group,n,k +!obsolete20220428 +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 if (error_file) then +!obsolete20220428 ! record in file clsm/bad_sat_param.tiles +!obsolete20220428 write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken +!obsolete20220428 +!obsolete20220428 ! write (41,*)tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & +!obsolete20220428 ! BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) +!obsolete20220428 ! write (41,*)tindex2(k),pfaf2(k),soil_class_top,soil_class_com(k), & +!obsolete20220428 ! BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 +!obsolete20220428 ! write ar.new, bf.dat, ts.dat, and soil_param.dat +!obsolete20220428 +!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & +!obsolete20220428 tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 ars1(k),ars2(k),ars3(k), & +!obsolete20220428 ara1(k),ara2(k),ara3(k),ara4(k), & +!obsolete20220428 arw1(k),arw2(k),arw3(k),arw4(k) +!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) +!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 tsa1(k),tsa2(k),tsb1(k),tsb2(k) +!obsolete20220428 +!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & +!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & +!obsolete20220428 BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & +!obsolete20220428 grav_vec(k),soc_vec(k),poc_vec(k), & +!obsolete20220428 a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & +!obsolete20220428 wpwet_surf(k),poros_surf(k), pmap (k) +!obsolete20220428 +!obsolete20220428 if (allocated (parms4file)) then +!obsolete20220428 parms4file (n, 1) = ara1(k) +!obsolete20220428 parms4file (n, 2) = ara2(k) +!obsolete20220428 parms4file (n, 3) = ara3(k) +!obsolete20220428 parms4file (n, 4) = ara4(k) +!obsolete20220428 parms4file (n, 5) = ars1(k) +!obsolete20220428 parms4file (n, 6) = ars2(k) +!obsolete20220428 parms4file (n, 7) = ars3(k) +!obsolete20220428 parms4file (n, 8) = arw1(k) +!obsolete20220428 parms4file (n, 9) = arw2(k) +!obsolete20220428 parms4file (n,10) = arw3(k) +!obsolete20220428 parms4file (n,11) = arw4(k) +!obsolete20220428 parms4file (n,12) = BEE(k) +!obsolete20220428 parms4file (n,13) = bf1(k) +!obsolete20220428 parms4file (n,14) = bf2(k) +!obsolete20220428 parms4file (n,15) = bf3(k) +!obsolete20220428 parms4file (n,16) = COND(k) +!obsolete20220428 parms4file (n,17) = gnu +!obsolete20220428 parms4file (n,18) = POROS(k) +!obsolete20220428 parms4file (n,19) = PSIS(k) +!obsolete20220428 parms4file (n,20) = tsa1(k) +!obsolete20220428 parms4file (n,21) = tsa2(k) +!obsolete20220428 parms4file (n,22) = tsb1(k) +!obsolete20220428 parms4file (n,23) = tsb2(k) +!obsolete20220428 parms4file (n,24) = wpwet (k) +!obsolete20220428 parms4file (n,25) = soildepth(k) +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 else ! .not. preserve_soiltype + + + ! This revised if block replaces the complex, nested if block commented out above + + if ( (ars1(n)==9999.) .or. (arw1(n)==9999.) ) then + + ! some parameter values are no-data --> find nearest tile k with good parameters + + dist_save = 1000000. + k = 0 + do i = 1,nbcatch + if(i /= n) then + if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then + + tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + if(tile_distance < dist_save) then + k = i + dist_save = tile_distance + endif + endif + endif + enddo + ! record in file clsm/bad_sat_param.tiles + write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken + + else + + ! nominal case, all parameters are good + + k = n + + end if + + ! for current tile n, write parameters of tile k into ar.new (20), bf.dat (30), ts.dat (40), + ! and soil_param.dat (42) + + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & - grav_vec(k),soc_vec(k),poc_vec(k), & - a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & - wpwet_surf(k),poros_surf(k), pmap (k) - + + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & + grav_vec(k),soc_vec(k),poc_vec(k), & + a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & + wpwet_surf(k),poros_surf(k), pmap(k) + + ! record parameters for later writing into catch_params.nc4 + if (allocated (parms4file)) then parms4file (n, 1) = ara1(k) parms4file (n, 2) = ara2(k) @@ -4107,81 +4301,22 @@ SUBROUTINE create_model_para_woesten (Maskfile) parms4file (n,21) = tsa2(k) parms4file (n,22) = tsb1(k) parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) + parms4file (n,24) = wpwet(k) parms4file (n,25) = soildepth(k) endif - - else - - dist_save = 1000000. - k = 0 - do i = 1,nbcatch - if(i /= n) then - if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then - - tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & - (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) - if(tile_distance < dist_save) then - k = i - dist_save = tile_distance - endif - endif - endif - enddo - write (41,*)n,k - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')& - tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & - grav_vec(k),soc_vec(k),poc_vec(k), & - a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & - wpwet_surf(k),poros_surf(k), pmap(k) - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) - parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) - endif - endif - endif - - if (error_file) then - write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + +!obsolete20220428 endif ! if (preserve_soiltype) then +!obsolete20220428 +!obsolete20220428 endif ! if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then + + if (error_file) then + write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & normerr1(n),normerr2(n),normerr3(n),normerr4(n) - write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) - endif - - END DO - + write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) + endif + + END DO ! n=1,nbcatch + ! Write(*,*) 'END COMPUTING MODEL PARA' close(10,status='keep') From a56e7a08c82ad6e7da8bc89bc26bb1cff0d9c506 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 29 Apr 2022 10:00:23 -0400 Subject: [PATCH 03/21] minor adjustment to output into catch_params.nc4 to maintain 0-diff after cleanup --- .../Utils/Raster/rmTinyCatchParaMod.F90 | 22 ++++++++++++------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 index 7417cf8de..76dba0fc5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 @@ -4245,7 +4245,19 @@ SUBROUTINE create_model_para_woesten (Maskfile) enddo ! record in file clsm/bad_sat_param.tiles write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken - + + ! Overwrite parms4file when filling in parameters from neighboring tile k. + ! For "good" tiles, keep parms4file as read earlier from catch_params.nc4, + ! which is why this must be done within the "then" block of the "if" statement. + ! This is necessary for backward 0-diff compatibility of catch_params.nc4. + + parms4file (n,12) = BEE(k) + parms4file (n,16) = COND(k) + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,24) = wpwet(k) + parms4file (n,25) = soildepth(k) + else ! nominal case, all parameters are good @@ -4275,7 +4287,7 @@ SUBROUTINE create_model_para_woesten (Maskfile) a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & wpwet_surf(k),poros_surf(k), pmap(k) - ! record parameters for later writing into catch_params.nc4 + ! record ar.new, bf.dat, and ts.dat parameters for later writing into catch_params.nc4 if (allocated (parms4file)) then parms4file (n, 1) = ara1(k) @@ -4289,20 +4301,14 @@ SUBROUTINE create_model_para_woesten (Maskfile) parms4file (n, 9) = arw2(k) parms4file (n,10) = arw3(k) parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) parms4file (n,13) = bf1(k) parms4file (n,14) = bf2(k) parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) parms4file (n,20) = tsa1(k) parms4file (n,21) = tsa2(k) parms4file (n,22) = tsb1(k) parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet(k) - parms4file (n,25) = soildepth(k) endif !obsolete20220428 endif ! if (preserve_soiltype) then From 10e4193805a8d7c182cadd7ed683d38dc174695d Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Mon, 2 May 2022 21:40:09 -0400 Subject: [PATCH 04/21] substantial cleanup of subroutine soil_para_hwsd(); added comments throughout --- .../Utils/Raster/mkCatchParam.F90 | 5 +- .../Utils/Raster/mod_process_hres_data.F90 | 932 ++++++++++++------ .../Utils/Raster/rmTinyCatchParaMod.F90 | 10 + 3 files changed, 631 insertions(+), 316 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index 3d25d1671..754859c59 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -30,7 +30,10 @@ PROGRAM mkCatchParam include 'netcdf.inc' - integer :: NC = i_raster, NR = j_raster + ! The default is NC=i_raster=8640, NR=j_raster=4320 via "use rmTinyCatchParaMod", but + ! NC and NR are typically overwritten through command-line arguments "-x nx -y ny". + + integer :: NC = i_raster, NR = j_raster character*4 :: LBSV = 'DEF' character*128 :: GridName = '' character*128 :: ARG, MaskFile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 5c776d1f0..36a0415b0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -38,6 +38,8 @@ MODULE process_hres_data real, parameter :: pi= MAPL_PI,RADIUS=MAPL_RADIUS integer, parameter :: N_GADM = 256 + 1, N_STATES = 50 +real, parameter :: SOILDEPTH_MIN_HWSD = 1334. ! minimum soil depth for HWSD soil parameters + type :: do_regrid integer :: NT integer, dimension (N_tiles_per_cell) :: TID @@ -3744,31 +3746,27 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) integer (kind=4), allocatable, dimension (:) :: tileid_vec,arrayA,arrayB integer (kind=2), allocatable, dimension (:) :: & data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6 - REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec,& - ncells_top,ncells_top_pro,ncells_sub_pro + REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec +! ncells_top,ncells_top_pro,ncells_sub_pro ! ncells_* not used integer(kind=2) , allocatable, dimension (:) :: ss_clay, & ss_sand,ss_clay_all,ss_sand_all,ss_oc_all REAL, ALLOCATABLE :: count_soil(:) integer, allocatable, target, dimension (:,:) :: tile_id integer, pointer :: iRaster(:,:) - integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf,vtype + integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf !,vtype real,dimension(4) :: cFamily real ,dimension(5) :: cF_lim logical :: first_entry = .true. - logical :: regrid,write_file + logical :: regrid,write_debug INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com - REAL :: sf,factor,wp_wetness,fac_count + REAL :: sf,factor,wp_wetness,fac_count,this_cond logical :: CatchParamsNC_file_exists REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file - ! PEAT-clsm modification - ! Below parameters are from Table 2 of: - ! Bechtold, M., G. J. M. De Lannoy, R. D. Koster, R. H. Reichle, S. Mahanama, W. Bleuten, M.A. Bourgault, C. Brümmer, - ! I. Burdun, A. R. Desai, K. Devito, T. Grünwald, M. Grygoruk, E. R. Humphreys, J. Klatt, J. Kurbatova, A. Lohila, - ! T. M. Munir, M.B. Nilsson, J. S. Price, M. Röhl, A. Schneider, and B. Tiemeyer, 2019. PEAT-CLSM: - ! A specific treatment of peatland hydrology in the NASA Catchment Land Surface Model. J. Adv. Model. Earth Sys., 11, - ! 2130-2162. doi: 10.1029/2018MS001574. - - REAL, PARAMETER :: pmap_thresh = 0.5 + + ! PEATCLSM: + REAL, PARAMETER :: PEATMAP_THRESHOLD_1 = 0.5 ! for converting PEATMAP area fraction into peat/non-peat (on raster grid) + REAL, PARAMETER :: PEATMAP_THRESHOLD_2 = 0.5 ! for aggregation from raster grid cells to tiles + REAL, DIMENSION (:), POINTER :: PMAP REAL, ALLOCATABLE, DIMENSION (:,:) :: PMAPR @@ -3817,56 +3815,78 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if (first_entry) then nullify(iraster) ; first_entry = .false. endif + + ! define orgC content thresholds for orgC classes 1-4 (low, medium, high, peat) + cF_lim(1) = 0. - cF_lim(2) = 0.4 ! 0.365 ! 0.3 - cF_lim(3) = 0.64 ! 0.585 ! 4.0 - cF_lim(4) = 15./1.72 ! 9.885 ! 8.5 + cF_lim(2) = 0.4 ! 0.365 ! 0.3 + cF_lim(3) = 0.64 ! 0.585 ! 4.0 + cF_lim(4) = 15./1.72 ! 15./1.72=8.72 ! 9.885 ! 8.5 cF_lim(5) = 100.0 + ! define number of mineral classes in each orgC class + nsoil_pcarbon(1) = 84 ! 84 nsoil_pcarbon(2) = nsoil_pcarbon(1) + 84 ! 84 nsoil_pcarbon(3) = nsoil_pcarbon(2) + 84 ! 57 + ! Read number of catchment-tiles (maxcat) from catchment.def file + fname='clsm/catchment.def' -! -! Reading number of cathment-tiles from catchment.def file -! + open (10,file=fname,status='old',action='read',form='formatted') read(10,*) maxcat + close (10,status='keep') + + ! Read tile-id raster file + + allocate(tile_id(1:nx,1:ny)) + + fname=trim(gfiler)//'.rst' + + open (10,file=fname,status='old',action='read', & + form='unformatted',convert='little_endian') + + do j=1,ny + read(10)tile_id(:,j) + end do + close (10,status='keep') + ! read soil depth data from GSWP2_soildepth_H[xx]V[yy].nc + ! + ! get info common to all H[xx]V[yy] rectangles: + fname =trim(c_data)//'SOIL-DATA/GSWP2_soildepth_H11V13.nc' status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) status = NF_CLOSE(ncid); VERIFY_(STATUS) + + ! GSWP2_soildepth_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 - allocate(soildepth(1:maxcat)) allocate(soil_high(1:i_highd,1:j_highd)) - allocate(count_soil(1:maxcat)) - allocate(tile_id(1:nx,1:ny)) allocate(net_data1 (1:nc_10,1:nr_10)) - fname=trim(gfiler)//'.rst' -! -! Reading tile-id raster file -! - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') -! -! reading soil depth data -! soil_high = -9999 do jx = 1,18 do ix = 1,36 @@ -3894,7 +3914,12 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) deallocate (net_data1) -! Regridding + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. nx_adj = nx ny_adj = ny @@ -3929,17 +3954,20 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) iRaster => tile_id end if -! Interpolation or aggregation on to catchment-tiles - - soildepth =0. - count_soil = 0. + ! Interpolate/aggregate soil depth from raster grid to catchment-tiles + + allocate(soildepth(1:maxcat)) + allocate(count_soil(1:maxcat)) + + soildepth = 0. ! 1-d tile space + count_soil = 0. ! 1-d tile space do j=1,ny_adj do i=1,nx_adj if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then if ((raster(i,j).gt.0)) then soildepth(iRaster(i,j)) = & - soildepth(iRaster(i,j)) + sf*raster(i,j) + soildepth(iRaster(i,j)) + sf*raster(i,j) ! integer "raster" --> real "soildepth" count_soil(iRaster(i,j)) = & count_soil(iRaster(i,j)) + 1. endif @@ -3949,28 +3977,50 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) DO n =1,maxcat if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) - soildepth(n) = max(soildepth(n),1334.) + soildepth(n) = max(soildepth(n),SOILDEPTH_MIN_HWSD) ! soildepth(n) = soildepth(n) + 2000. ! soildepth(n) = min(soildepth(n),8000.) END DO deallocate (SOIL_HIGH) - deallocate (count_soil) + !deallocate (count_soil) ! do not deallocate, needed again shortly NULLIFY(Raster) -! -! Reading NGDC-HWSD-STATSGO merged Soil Properties -! + + ! --------------------------------------------------------------------------------- + ! + ! Read NGDC-HWSD-STATSGO merged soil texture from SoilProperties_H[xx]V[yy].nc' + ! + ! get info common to all H[xx]V[yy] rectangles (could in theory differ from that + ! of soildepth data read above but is the same as of 29 Apr 2022). + fname =trim(c_data)//'SOIL-DATA/SoilProperties_H11V13.nc' status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_CLOSE(ncid) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_CLOSE(ncid) + + ! SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains soil texture data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 - regrid = nx/=i_highd .or. ny/=j_highd + !regrid = nx/=i_highd .or. ny/=j_highd ! not needed here, done below + allocate(net_data1 (1:nc_10,1:nr_10)) allocate(net_data2 (1:nc_10,1:nr_10)) allocate(net_data3 (1:nc_10,1:nr_10)) @@ -3987,13 +4037,13 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) allocate(oc_sub (1:i_highd,1:j_highd)) allocate(grav_grid(1:i_highd,1:j_highd)) - sand_top = -9999. - clay_top = -9999. - oc_top = -9999. - sand_sub = -9999. - clay_sub = -9999. - oc_sub = -9999. - grav_grid= -9999. + sand_top = -9999 ! integer*2 + clay_top = -9999 ! integer*2 + oc_top = -9999 ! integer*2 + sand_sub = -9999 ! integer*2 + clay_sub = -9999 ! integer*2 + oc_sub = -9999 ! integer*2 + grav_grid= -9999 ! integer*2 do jx = 1,18 do ix = 1,36 @@ -4004,7 +4054,9 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if(status == 0) then status = NF_GET_att_INT (ncid, NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) status = NF_GET_att_INT (ncid, NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) + ! assume UNDEF and ScaleFactor (sf) are the same for *all* variables read below + ! (ok for SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022). + status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) status = NF_GET_att_REAL (ncid, 4,'ScaleFactor',sf); VERIFY_(STATUS) status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) status = NF_GET_VARA_INT (ncid, 5,(/1,1/),(/nc_10,nr_10/),net_data2); VERIFY_(STATUS) @@ -4035,22 +4087,32 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) endif end do end do + + deallocate (net_data1) + deallocate (net_data2) + deallocate (net_data3) + deallocate (net_data4) + deallocate (net_data5) + deallocate (net_data6) + deallocate (net_data7) + ! ---------------------------------------------------------------------------- + if(use_PEATMAP) then - print *, 'PMAP_THRESH : ', pmap_thresh + print *, 'PEATMAP_THRESHOLD_1 : ', PEATMAP_THRESHOLD_1 allocate(pmapr (1:i_highd,1:j_highd)) status = NF_OPEN ('data/CATCH/PEATMAP_mask.nc4', NF_NOWRITE, ncid) status = NF_GET_VARA_REAL (ncid,NC_VarID(NCID,'PEATMAP'), (/1,1/),(/i_highd, j_highd/), pmapr) ; VERIFY_(STATUS) -! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat -! ------------------------------------------------------------------------------------------------------------ + ! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat + where (oc_sub*sf >= cF_lim(4)) oc_sub = NINT(8./sf) endwhere -! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top -! --------------------------------------------------- - where (pmapr >= pmap_thresh) + ! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top + + where (pmapr >= PEATMAP_THRESHOLD_1) oc_top = NINT(33.0/sf) endwhere @@ -4058,20 +4120,19 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) status = NF_CLOSE(ncid) endif - deallocate (net_data1) - deallocate (net_data2) - deallocate (net_data3) - deallocate (net_data4) - deallocate (net_data5) - deallocate (net_data6) - deallocate (net_data7) + ! ---------------------------------------------------------------------------- -! now regridding + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. nx_adj = nx ny_adj = ny - regrid = nx/=i_highd .or. ny/=j_highd + regrid = nx/=i_highd .or. ny/=j_highd if(regrid) then if(nx > i_highd) then @@ -4133,15 +4194,16 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) raster6 => oc_sub raster => grav_grid end if + + ! ---------------------------------------------------------------------------- - - ! compute peat fraction on tile for CLM45+ + ! compute peat fraction on tile for CLM45+ (for fires?) allocate(pmap (1:maxcat)) - allocate(count_soil(1:maxcat)) + !allocate(count_soil(1:maxcat)) ! already allocated above - pmap = 0. - count_soil = 0. + pmap = 0. ! 1-d tile space; peat fraction in tile based on oc_top + count_soil = 0. ! 1-d tile space do j=1,ny_adj do i=1,nx_adj @@ -4156,14 +4218,19 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) where (count_soil > 0) pmap = pmap /count_soil - deallocate (count_soil) -! Deallocate large arrays + !deallocate (count_soil) ! do not deallocate, needed again shortly + + ! ---------------------------------------------------------------------------- + + ! get number of "land" pixels (i1) on raster grid allocate(land_pixels(1:size(iRaster,1),1:size(iRaster,2))) land_pixels = (iRaster >=1).and.(iRaster<=maxcat) i1 = count(land_pixels) deallocate (land_pixels) + ! allocate 1-d arrays for all "land" pixels on raster grid + allocate (tileid_vec(1:i1)) allocate (data_vec1 (1:i1)) allocate (data_vec2 (1:i1)) @@ -4171,37 +4238,49 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) allocate (data_vec4 (1:i1)) allocate (data_vec5 (1:i1)) allocate (data_vec6 (1:i1)) + + ! allocate 1-d arrays for all "land" tiles + allocate (grav_vec (1:maxcat)) allocate (soc_vec (1:maxcat)) allocate (poc_vec (1:maxcat)) - allocate (ncells_top (1:maxcat)) - allocate (ncells_top_pro (1:maxcat)) - allocate (ncells_sub_pro (1:maxcat)) - allocate(count_soil(1:maxcat)) + !allocate (ncells_top (1:maxcat)) ! ncells_* not used + !allocate (ncells_top_pro (1:maxcat)) ! ncells_* not used + !allocate (ncells_sub_pro (1:maxcat)) ! ncells_* not used + !allocate(count_soil(1:maxcat)) + count_soil = 0. grav_vec = 0. - soc_vec = 0. - poc_vec = 0. - ncells_top = 0. - ncells_top_pro = 0. - ncells_sub_pro = 0. + soc_vec = 0. ! soil orgC (top layer 0-30) + poc_vec = 0. ! soil orgC (profile layer 0-100) + + !ncells_top = 0. ! ncells_* not used + !ncells_top_pro = 0. ! ncells_* not used + !ncells_sub_pro = 0. ! ncells_* not used n =1 do j=1,ny_adj do i=1,nx_adj if((iRaster(i,j).ge.1).and.(iRaster(i,j).le.maxcat)) then - tileid_vec (n) = iRaster(i,j) - data_vec1 (n) = Raster1(i,j) - data_vec2 (n) = Raster2(i,j) - data_vec3 (n) = Raster3(i,j) - data_vec4 (n) = Raster4(i,j) - data_vec5 (n) = Raster5(i,j) - data_vec6 (n) = Raster6(i,j) + ! map from 2-d raster array to 1-d raster vec + + tileid_vec (n) = iRaster(i,j) ! iRaster => tile_id int*4 + data_vec1 (n) = Raster1(i,j) ! raster1 => clay_top int*2 + data_vec2 (n) = Raster2(i,j) ! raster2 => sand_top int*2 + data_vec3 (n) = Raster3(i,j) ! raster3 => oc_top int*2 + data_vec4 (n) = Raster4(i,j) ! raster4 => clay_sub int*2 + data_vec5 (n) = Raster5(i,j) ! raster5 => sand_sub int*2 + data_vec6 (n) = Raster6(i,j) ! raster6 => oc_sub int*2 + + ! BUG??? It is unclear why here grav_vec is filled in the order of "tile_id" + ! while data_vec[x] is filled in the order of the long/lat grid. + ! Not sure if grav_vec is processed correctly below! + ! -reichle, 29 Apr 2022 if ((raster(i,j).gt.0)) then grav_vec(iRaster(i,j)) = & - grav_vec(iRaster(i,j)) + sf*raster(i,j) + grav_vec(iRaster(i,j)) + sf*raster(i,j) ! raster => grav_grid int*2 count_soil(iRaster(i,j)) = & count_soil(iRaster(i,j)) + 1. endif @@ -4214,16 +4293,15 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if(count_soil(n)/=0.) grav_vec(n)=grav_vec(n)/count_soil(n) END DO - deallocate (grav_grid) deallocate (count_soil) - NULLIFY(Raster) - - NULLIFY(Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) - deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub) + NULLIFY(Raster,Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) + deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub,grav_grid) deallocate (tile_id) - allocate (arrayA (1:i1)) - allocate (arrayB (1:i1)) + ! sort 1-d land pixels vectors according to tile_id + + allocate (arrayA (1:i1)) ! 1-d land pixels on raster grid + allocate (arrayB (1:i1)) ! 1-d land pixels on raster grid arrayA = tileid_vec arrayB = data_vec1 @@ -4254,11 +4332,15 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) arrayB = data_vec6 call MAPL_Sort (arrayA, arrayB) data_vec6 = arrayB + tileid_vec= arrayA + deallocate (arrayA, arrayB) -! -! Reading Woesten Soil Parameters and CLSM tau parameters -! + + ! -------------------------------------------------------------------- + ! + ! Read Woesten Soil Parameters and CLSM tau parameters for soil classes (1:253) + allocate(a_sand (1:n_SoilClasses)) allocate(a_clay (1:n_SoilClasses)) allocate(a_silt (1:n_SoilClasses)) @@ -4274,33 +4356,61 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) allocate(btau_2cm(1:n_SoilClasses)) allocate(a_wpsurf(1:n_SoilClasses)) allocate(a_porosurf(1:n_SoilClasses)) + + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + if(use_PEATMAP) then fname = trim(c_data)//'SoilClasses-SoilHyd-TauParam.peatmap' else fname = trim(c_data)//'SoilClasses-SoilHyd-TauParam.dat' endif - table_map = 0 + + table_map = 0 ! 100-by-3 look-up table + open (11, file=trim(fname), form='formatted',status='old', & action = 'read') - read (11,'(a)')fout + read (11,'(a)')fout ! read header line + do n =1,n_SoilClasses + read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) + ! assemble scalar structure that holds mineral percentages of soil class n + min_percs%clay_perc = a_clay(n) min_percs%silt_perc = a_silt(n) min_percs%sand_perc = a_sand(n) + + ! "soil_class" is an integer function (see rmTinyCatchParam.F90) that assigns + ! an integer (mineral) soil class [1-100] for a given mineral percentage triplet + + ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and + ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. + if(n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n - end do + end do ! n=1,n_SoilClasses + close (11,status='keep') -! -! When Woesten Soil Parameters are not available for a particular Soil Class -! ,as assumed by tiny triangles in HWSD soil triangle, Woesten Soil -! parameters from the nearest available tiny triangle will be substituted. -! + + ! ------------------------------------------------------------ + ! + ! When Woesten Soil Parameters are not available for a particular Soil Class, + ! as defined by "tiny" triangles in HWSD soil triangle, Woesten Soil + ! parameters from the nearest available "tiny" triangle will be substituted. + ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). + do n =1,10 do k=1,n*2 -1 @@ -4374,30 +4484,47 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) !$OMP sf,data_vec1,data_vec2,data_vec3, & !$OMP data_vec4,data_vec5,data_vec6,cF_lim, & !$OMP table_map,soil_class_top,soil_class_com, & -!$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& -!$OMP ncells_sub_pro,use_PEATMAP) & +!$OMP soc_vec,poc_vec,use_PEATMAP) & +!ncells_* not used !$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& +!ncells_* not used !$OMP ncells_sub_pro,use_PEATMAP) & !$OMP PRIVATE(n,i,j,k,icount,t_count,i1,i2,ss_clay, & !$OMP ss_sand,ss_clay_all,ss_sand_all, & !$OMP ss_oc_all,cFamily,factor,o_cl,o_clp,ktop, & -!$OMP min_percs, fac_count, write_file) +!$OMP min_percs, fac_count, write_debug) + + ! loop through tiles (split into two loops for OpenMP) DO t_count = 1,n_threads DO n = low_ind(t_count),upp_ind(t_count) - write_file = .false. + write_debug = .false. -! if (n==171010) write_file = .true. +! if (n==171010) write_debug = .true. + + ! initialize "icount" when starting loop through n at low_ind(t_count) + ! recall: tileid_vec is a 1-d vector that covers all land pixels on the raster grid that + ! contains the (sorted) tile IDs, with matching parameter vectors data_vec[x] if(n==low_ind(t_count)) then icount = 1 + ! Not sure what the following loops do. Why not check backwards from low_ind(t_count)?? do k=1,low_ind(t_count) - 1 - do while (tileid_vec(icount)== k) + do while (tileid_vec(icount)== k) icount = icount + 1 end do end do endif + + ! ------------------------------------------------------------------ + ! + ! determine the land raster grid cells i1:i2 that make up tile n + + ! NOTE change in meaning of "i1": + ! + ! before: i1 = total no. of land pixels on the raster grid + ! now: i1 = starting index of land raster grid cells (within 1-d vector) that make up tile n (?) - i1 = icount + i1 = icount loop: do while (tileid_vec(icount)== n) if(icount <= size(tileid_vec,1)) icount = icount + 1 @@ -4405,49 +4532,77 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) end do loop i2 = icount -1 - i = i2 - i1 + 1 + i = i2 - i1 + 1 ! number of land raster grid cells that make up tile n (?) + + + ! ------------------------------------------------------------------- + ! + ! prep data + + allocate(ss_clay (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? + allocate(ss_sand (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - allocate(ss_clay (1:2*i)) - allocate(ss_sand (1:2*i)) - allocate(ss_clay_all(1:2*i)) - allocate(ss_sand_all(1:2*i)) - allocate(ss_oc_all (1:2*i)) + allocate(ss_clay_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_sand_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_oc_all (1:2*i)) ! for top (0-30) and sub (30-100) layers - ss_clay = 0 - ss_sand = 0 - ss_clay_all= 0 - ss_sand_all= 0 - ss_oc_all = 0 + ss_clay = 0 ! int*2 -- why only clay and sand for top layer and not orgC ?? + ss_sand = 0 ! int*2 + + ss_clay_all= 0 ! int*2 + ss_sand_all= 0 ! int*2 + ss_oc_all = 0 ! int*2 - ss_clay_all (1:i) = data_vec1(i1:i2) + ss_clay_all (1:i) = data_vec1(i1:i2) ! put top layer info into first i elements (1:i) ss_sand_all (1:i) = data_vec2(i1:i2) ss_oc_all (1:i) = data_vec3(i1:i2) - ss_clay_all (1+i:2*i) = data_vec4(i1:i2) + + ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) ss_sand_all (1+i:2*i) = data_vec5(i1:i2) ss_oc_all (1+i:2*i) = data_vec6(i1:i2) + + ! ----------------------------------------------------------------------- + ! + ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n + cFamily = 0. + factor = 1. do j=1,i - if(j <= i) factor = 1. + ! if(j <= i) factor = 1. if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor end do - if (sum(cFamily) == 0.) o_cl = 1 - if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) + if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) + + if (.not. use_PEATMAP) then + + ! assign dominant *top* layer org soil class (even if only a minority of the contributing + ! raster grid cells is peat) + + if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) - if (use_PEATMAP) then - ! if 50% or more of the tile surface is covered with peat, we assume the tile is peat - if (cFamily(4)/real(i) > 0.5) then + else + + ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing + ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) + + if (cFamily(4)/real(i) > PEATMAP_THRESHOLD_2) then o_cl = 4 else - if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) + if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) ! o_cl = 1, 2, or 3 endif - endif + endif + + + ! determine aggregate/dominant orgC *profile* (0-100) soil class ("o_clp") of tile n, + ! weight factor=1. for top (0-30) layer and weight factor=2.33 for sub (30-100) layer + cFamily = 0. do j=1,2*i @@ -4458,55 +4613,95 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor end do + + ! NOTE: For PEATMAP, oc_sub was cut back to 8./sf above: + ! "! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat" + ! "where (oc_sub*sf >= cF_lim(4)) " + ! " oc_sub = NINT(8./sf) " + ! "endwhere " + ! For PEATMAP, the maxloc statement below should therefore result in o_clp = 1, 2, or 3 only (?) if (sum(cFamily) == 0.) o_clp = 1 - if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) + if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) + + ! ---------------------------------------------------------------------------------------- + ! + ! Determine *top* layer mineral/organic soil class of tile n if(o_cl == 4) then + + ! Top-layer soil class of tile n is peat. + ! Compute average top-layer orgC (only across raster grid cells whose top layer is peat). + soil_class_top(n) = n_SoilClasses ktop = 0 do j=1,i - if(ss_oc_all(j)*sf >= cF_lim(4)) then + ! avg only across contributing raster grid cells that are peat + if(ss_oc_all(j)*sf >= cF_lim(4)) then soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ktop = ktop + 1 endif end do if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop - ncells_top(n) = 100.*float(ktop)/float(i) + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used + else - k = 1 - ktop = 1 + + ! Top-layer soil class of tile n is mineral. + ! Compute average top-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. - do j=1,i + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + ktop = 0 !cleanup k counter + + do j=1,i ! loop only through top-layer elements of ss_*_all + + ! avg only across contributing raster grid cells with orgC class as that assigned to tile n if((ss_oc_all(j)*sf >= cF_lim(o_cl)).and.(ss_oc_all(j)*sf < cF_lim(o_cl + 1))) then - if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then - ss_clay (k) = ss_clay_all(j) - ss_sand (k) = ss_sand_all(j) - if((ss_clay (k) + ss_sand (k)) > 9999) then - if(ss_clay (k) >= ss_sand (k)) then - ss_sand (k) = 10000 - ss_clay (k) + + if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values + + ktop = ktop + 1 !cleanup k counter + ss_clay (ktop) = ss_clay_all(j) + ss_sand (ktop) = ss_sand_all(j) + + ! adjust clay and sand content if outside joint physical bounds + if((ss_clay (ktop) + ss_sand (ktop)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) + if(ss_clay (ktop) >= ss_sand (ktop)) then + ss_sand (ktop) = 10000 - ss_clay (ktop) else - ss_clay (k) = 10000 - ss_sand (k) + ss_clay (ktop) = 10000 - ss_sand (ktop) endif endif - soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf - k = k + 1 - ktop = ktop + 1 + soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ! sum up top-layer orgC + !k = k + 1 !cleanup k counter + !ktop = ktop + 1 !cleanup k counter endif endif end do - k = k - 1 - ktop = ktop -1 - if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop - ncells_top(n) = 100.*float(ktop)/float(i) - if (write_file) write(80+n,*)ktop,o_cl + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter + + if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop ! normalize top-layer orgC + + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used + + ! debugging output + if (write_debug) write(80+n,*)ktop,o_cl if(ktop > 0) then - if (write_file) write (80+n,*)ss_clay(1:ktop) - if (write_file) write (80+n,*)ss_sand(1:ktop) + if (write_debug) write (80+n,*)ss_clay(1:ktop) + if (write_debug) write (80+n,*)ss_sand(1:ktop) endif + + ! Determine the raster grid cell j that has (top-layer) clay/sand content closest + ! to the average (top-layer) clay/sand across all raster grid cells within the + ! dominant orgC class. + j = center_pix_int0(sf, ktop,ktop, ss_clay(1:ktop),ss_sand(1:ktop)) - if (write_file) write(80+n,*)j + + ! Assign soil class of raster grid cell j to tile n if(j >=1) then min_percs%clay_perc = ss_clay(j)*sf @@ -4514,130 +4709,199 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf soil_class_top (n) = table_map(soil_class (min_percs),o_cl) endif + + ! debugging output + if (write_debug) write(80+n,*)j + endif - if (write_file) write(80+n,*)soil_class_top (n) + + ! debugging output + if (write_debug) write(80+n,*)soil_class_top (n) + + ! ------------------------------------------------------------------------------- + ! + ! determine aggregate sand/clay/orgC for *profile* layer of tile n + if(o_clp == 4) then + + ! Profile-layer soil class of tile n is peat. + ! Compute average profile-layer orgC (only across raster grid cells and layers that are peat) + soil_class_com(n) = n_SoilClasses fac_count = 0. k =0 ktop =0 do j=1,2*i if(ss_oc_all(j)*sf >= cF_lim(4)) then - if(j <= i) factor = 1. - if(j > i) factor = 2.33 - if(j > i) k = k + 1 - if(j <= i) ktop = ktop + 1 - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor - fac_count = fac_count + factor + if(j <= i) factor = 1. ! top layer contribution 1 <= j <=i + if(j > i) factor = 2.33 ! sub layer contribution i+1 <= j <=2*i + if(j > i) k = k + 1 ! sub layer counter + if(j <= i) ktop = ktop + 1 ! top layer counter + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC + fac_count = fac_count + factor ! sum of weights endif end do - if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count - ncells_sub_pro(n) = 100.*float(k)/float(i) - ncells_top_pro(n) = 100.*float(ktop)/float(i) + if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count ! normalize + !ncells_sub_pro(n) = 100.*float(k)/float(i) ! ncells_* not used + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used else - k = 1 - ktop = 1 + + ! Profile-layer soil class of tile n is mineral. + ! Compute average profile-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. + + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + k = 0 !cleanup k counter + ktop = 0 !cleanup k counter ss_clay=0 ss_sand=0 fac_count = 0. - do j=1,2*i + do j=1,2*i ! loop through both top (1<=j<=i) layer and sub (i+1<=j<=2*i) layer elements + + ! avg only across contributing raster grid cells and layers with orgC class as that assigned to tile n if((ss_oc_all(j)*sf >= cF_lim(o_clp)).and.(ss_oc_all(j)*sf < cF_lim(o_clp + 1))) then - if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then - if(j <= i) factor = 1. - if(j > i) factor = 2.33 - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor + + if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values + + if(j <= i) factor = 1. ! top layer contribution + if(j > i) factor = 2.33 ! sub layer contribution + + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC fac_count = fac_count + factor - if(j <= i) then - ss_clay (k) = ss_clay_all(j) - ss_sand (k) = ss_sand_all(j) - if((ss_clay (k) + ss_sand (k)) > 9999) then - if(ss_clay (k) >= ss_sand (k)) then - ss_sand (k) = 10000 - ss_clay (k) - else - ss_clay (k) = 10000 - ss_sand (k) - endif - endif - k = k + 1 - ktop = ktop + 1 - else - ss_clay (k) = ss_clay_all(j) - ss_sand (k) = ss_sand_all(j) - if((ss_clay (k) + ss_sand (k)) > 9999) then - if(ss_clay (k) >= ss_sand (k)) then - ss_sand (k) = 10000 - ss_clay (k) - else - ss_clay (k) = 10000 - ss_sand (k) - endif - endif - k = k + 1 - endif - endif + + k = k + 1 ! counter for top and sub contributions !cleanup k counter + + if (j<=i) ktop = ktop + 1 ! counter for top contributions only !cleanup k counter + + +!obsolete20220502 The code within the if-then and if-else statements below was nearly identical, +!obsolete20220502 except for the omission of the ktop counter from the else block. +!obsolete20220502 +!obsolete20220502 if(j <= i) then + + ss_clay (k) = ss_clay_all(j) + ss_sand (k) = ss_sand_all(j) + + ! adjust clay and sand content if outside joint physical bounds + if((ss_clay (k) + ss_sand (k)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) + if(ss_clay (k) >= ss_sand (k)) then + ss_sand (k) = 10000 - ss_clay (k) + else + ss_clay (k) = 10000 - ss_sand (k) + endif + endif + !k = k + 1 !cleanup k counter + !ktop = ktop + 1 !cleanup k counter + +!obsolete20220502 else +!obsolete20220502 ss_clay (k) = ss_clay_all(j) +!obsolete20220502 ss_sand (k) = ss_sand_all(j) +!obsolete20220502 if((ss_clay (k) + ss_sand (k)) > 9999) then +!obsolete20220502 if(ss_clay (k) >= ss_sand (k)) then +!obsolete20220502 ss_sand (k) = 10000 - ss_clay (k) +!obsolete20220502 else +!obsolete20220502 ss_clay (k) = 10000 - ss_sand (k) +!obsolete20220502 endif +!obsolete20220502 endif +!obsolete20220502 !k = k + 1 !cleanup k counter +!obsolete20220502 endif + endif endif end do - k = k - 1 - ktop = ktop -1 - if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count - ncells_top_pro(n) = 100.*float(ktop)/float(i) - ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) - - if (write_file) write (80+n,*)ktop,k,o_cl - if (write_file) write (80+n,*)ss_clay(1:k) - if (write_file) write (80+n,*)ss_sand(1:k) + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter + + if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count ! normalize profile-layer orgC + + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used + !ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) ! ncells_* not used + + ! debugging output + if (write_debug) write (80+n,*)ktop,k,o_cl + if (write_debug) write (80+n,*)ss_clay(1:k) + if (write_debug) write (80+n,*)ss_sand(1:k) + + ! Determine the raster grid cell and layer j that has clay/sand content closest + ! to the average (profile) clay/sand across all raster grid cells within the + ! dominant orgC class. + j = center_pix_int0 (sf, ktop,k, ss_clay(1:k),ss_sand(1:k)) - if (write_file) write(80+n,*) j + + ! Assign soil class of raster grid cell and layer j to tile n + if(j >=1) then min_percs%clay_perc = ss_clay(j)*sf min_percs%sand_perc = ss_sand(j)*sf min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf soil_class_com (n) = table_map(soil_class (min_percs),o_clp) endif - if (write_file) write(80+n,*) soil_class_com (n) - if (write_file) close(80+n) + + ! debugging output + if (write_debug) write(80+n,*) j + if (write_debug) write(80+n,*) soil_class_com (n) + if (write_debug) close(80+n) + endif + deallocate (ss_clay,ss_sand,ss_clay_all,ss_sand_all,ss_oc_all) + END DO - END DO + END DO ! loop through tiles !$OMP ENDPARALLELDO ! call process_peatmap (nx, ny, gfiler, pmap) + ! ----------------------------------------------------------------------------- + ! + ! apply final touches and write output files: + ! - soil_param.first + ! - tau_param.dat + ! - catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters ONLY; + ! parameters from ar.new, bf.dat, and ts.dat parameters will be + ! added to catch_params.nc4 by subroutine create_model_para_woesten()] + inquire(file='clsm/catch_params.nc4', exist=CatchParamsNC_file_exists) if(CatchParamsNC_file_exists) then status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) allocate (parms4file (1:maxcat, 1:10)) endif - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat + fname ='clsm/soil_param.first' open (11,file=trim(fname),form='formatted',status='unknown',action = 'write') fname ='clsm/tau_param.dat' open (12,file=trim(fname),form='formatted',status='unknown',action = 'write') - fname ='clsm/mosaic_veg_typs_fracs' - open (13,file=trim(fname),form='formatted',status='old',action = 'read') + ! open catchment.def for reading tile index and Pfafstetter index + + fname='clsm/catchment.def' + open (10,file=fname,status='old',action='read',form='formatted') + +!obsolete20220502 read(10,*) maxcat + +!obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' +!obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') do n = 1, maxcat - read (10,*) tindex,pfafindex - read (13,*) tindex,pfafindex,vtype +!obsolete20220502 read (13,*) tindex,pfafindex,vtype + + ! fill gaps from neighbor for rare missing values caused by inconsistent masks - ! fill gaps from neighbor for rare missing values came from inconsistent masks if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then - ! if com-layer has data the issues is only with top-layer + ! if com-layer has data, the issue is only with top-layer ! ------------------------------------------------------- if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) - ! if there is nothing look for the neighbor - ! ----------------------------------------- + ! if there is nothing, look for the neighbor + ! ------------------------------------------ if (soil_class_com (n) == -9999) then do k = 1, maxcat @@ -4665,28 +4929,40 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) fac = soil_class_com(n) if(use_PEATMAP) then - ! the maximum peat soil depth is set to the value Michel used to derive parameters (1334.) + ! the maximum peat soil depth is set to the value Michel used to derive parameters (5000.) if (fac_surf == 253) soildepth(n) = 5000. ! max(soildepth(n),5000.) - ! reseet subsurface tro peat if surface soil type is peat + ! reset subsurface to peat if surface soil type is peat if (fac_surf == 253) fac = 253 endif wp_wetness = a_wp(fac) /a_poros(fac) + + this_cond = a_aksat(fac)/exp(-1.0*zks*gnu) + + ! read tile index and Pfafstetter index from catchment.def + + read (10,*) tindex,pfafindex + + ! write soil_param.first write (11,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')tindex,pfafindex, & fac_surf, fac, a_bee(fac),a_psis(fac),a_poros(fac),& - a_aksat(fac)/exp(-1.0*zks*gnu),wp_wetness,soildepth(n), & + this_cond,wp_wetness,soildepth(n), & grav_vec(n),soc_vec(n),poc_vec(n), & a_sand(fac_surf),a_clay(fac_surf),a_sand(fac),a_clay(fac), & a_wpsurf(fac_surf)/a_porosurf(fac_surf),a_porosurf(fac_surf), pmap(n) + + ! write tau_param.dat write (12,'(i10,i8,4f10.7)')tindex,pfafindex, & atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) + ! write catch_params.nc [soil hydraulic and srfexc-rzexc time scale parameters] + if (allocated (parms4file)) then parms4file (n, 1) = a_bee(fac) - parms4file (n, 2) = a_aksat(fac)/exp(-1.0*zks*gnu) + parms4file (n, 2) = this_cond ! a_aksat(fac)/exp(-1.0*zks*gnu) parms4file (n, 3) = a_poros(fac) parms4file (n, 4) = a_psis(fac) parms4file (n, 5) = wp_wetness @@ -4698,21 +4974,29 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) endif end do + + ! add "header" line to the bottom of soil_param.first + write (11,'(a)')' ' write (11,'(a)')'FMT=i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4,f8.4' write (11,'(a)')'TileIndex PfafID SoilClassTop SoilClassProfile BEE PSIS POROS Ks_at_SURF WPWET SoilDepth %Grav %OCTop %OCProf %Sand_top %Clay_top %Sand_prof %Clay_prof WPWET_SURF POROS_SURF PMAP' + close (10, status = 'keep') close (11, status = 'keep') close (12, status = 'keep') - close (13, status = 'keep') + +!obsolete20220502 close (13, status = 'keep') deallocate (data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6) deallocate (tileid_vec) deallocate (a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & atau_2cm,btau_2cm) - deallocate (soildepth, grav_vec,soc_vec,poc_vec,& - ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) + deallocate (soildepth, grav_vec,soc_vec,poc_vec,soil_class_top,soil_class_com) + !ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) ! ncells_* not used + + ! write catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters] + if(CatchParamsNC_file_exists) then status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) @@ -4732,95 +5016,113 @@ END SUBROUTINE soil_para_hwsd ! -------------------------------------------------------------------------------------------------------- - INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) - - implicit none - - integer (kind =2), dimension (:), intent (in) :: x,y - integer, intent (in) :: ktop,ktot - real, intent (in) :: sf - real :: xi,xj,yi,yj,xx0,yy0,zz0 - real, allocatable, dimension (:,:) :: length_m - real, allocatable, dimension (:) :: length - real, intent (inout) :: x0,y0,z0 - integer :: i,j,npix - logical, intent(in) :: ext_point - real :: zi, zj - - allocate (length_m (1:ktot,1:ktot)) - allocate (length (1:ktot)) - length_m =0. - length =0. - - center_pix_int = -9999 - if(ktot /= 0) then - do i = 1,ktot - xi = sf*x(i) - yi = sf*y(i) - zi = 100. - xi - yi - if (.not. ext_point) then - x0 = xi - y0 = yi - z0 = zi - endif - - do j = 1,ktot - xj = sf*x(j) - yj = sf*y(j) - zj = 100. - xj - yj - xx0= xj - x0 - yy0= yj - y0 - zz0= zj - z0 - - if(ktot > ktop) then - if(j <= ktop) then - length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 - else - length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) - endif - else - length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 - endif - end do - length (i) = sum(length_m (i,:)) - end do - - center_pix_int = minloc(length,dim=1) - endif - - END FUNCTION center_pix_int - - ! +!obsolete20220502 INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) +!obsolete20220502 +!obsolete20220502 implicit none +!obsolete20220502 +!obsolete20220502 integer (kind =2), dimension (:), intent (in) :: x,y +!obsolete20220502 integer, intent (in) :: ktop,ktot +!obsolete20220502 real, intent (in) :: sf +!obsolete20220502 real :: xi,xj,yi,yj,xx0,yy0,zz0 +!obsolete20220502 real, allocatable, dimension (:,:) :: length_m +!obsolete20220502 real, allocatable, dimension (:) :: length +!obsolete20220502 real, intent (inout) :: x0,y0,z0 +!obsolete20220502 integer :: i,j,npix +!obsolete20220502 logical, intent(in) :: ext_point +!obsolete20220502 real :: zi, zj +!obsolete20220502 +!obsolete20220502 allocate (length_m (1:ktot,1:ktot)) +!obsolete20220502 allocate (length (1:ktot)) +!obsolete20220502 length_m =0. +!obsolete20220502 length =0. +!obsolete20220502 +!obsolete20220502 center_pix_int = -9999 +!obsolete20220502 if(ktot /= 0) then +!obsolete20220502 do i = 1,ktot +!obsolete20220502 xi = sf*x(i) +!obsolete20220502 yi = sf*y(i) +!obsolete20220502 zi = 100. - xi - yi +!obsolete20220502 if (.not. ext_point) then +!obsolete20220502 x0 = xi +!obsolete20220502 y0 = yi +!obsolete20220502 z0 = zi +!obsolete20220502 endif +!obsolete20220502 +!obsolete20220502 do j = 1,ktot +!obsolete20220502 xj = sf*x(j) +!obsolete20220502 yj = sf*y(j) +!obsolete20220502 zj = 100. - xj - yj +!obsolete20220502 xx0= xj - x0 +!obsolete20220502 yy0= yj - y0 +!obsolete20220502 zz0= zj - z0 +!obsolete20220502 +!obsolete20220502 if(ktot > ktop) then +!obsolete20220502 if(j <= ktop) then +!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 +!obsolete20220502 else +!obsolete20220502 length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) +!obsolete20220502 endif +!obsolete20220502 else +!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 +!obsolete20220502 endif +!obsolete20220502 end do +!obsolete20220502 length (i) = sum(length_m (i,:)) +!obsolete20220502 end do +!obsolete20220502 +!obsolete20220502 center_pix_int = minloc(length,dim=1) +!obsolete20220502 endif +!obsolete20220502 +!obsolete20220502 END FUNCTION center_pix_int +!obsolete20220502 +!obsolete20220502 ! +!obsolete20220502 + ! ==================================================================== ! INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) implicit none - ! sf = 0.01 (integer to real scale factor), ktop = # of pixels in top layer + + ! In a nutshell, given a list of clay/sand pairs, this function determines + ! the element (pair) in this list that is closest to the average clay/sand + ! across all pairs. + ! + ! The input list of clay/sand can consist of only top (0-30) layer clay/sand + ! pairs, or of pairs of clay/sand pairs for the top (0-30) and sub (30-70) + ! layers. In the latter case, a weighted average is computed. + ! + ! This is to ensure that ultimately the clay/sand values assigned to a tile + ! represent an actual soil class. + ! + ! sf = 0.01 (integer to real scale factor) + ! ktop = # of pixels in top layer ! ktot = total # of pixels, top + subsurface combined - ! x (clay), y (sand_ + ! x (clay), y (sand) integer (kind =2), dimension (:), intent (in) :: x,y - integer, intent (in) :: ktop,ktot - real, intent (in) :: sf + integer, intent (in) :: ktop,ktot + real, intent (in) :: sf + real :: xi,xj,yi,yj real :: length integer :: i,j,npix real :: zi, zj, mindist,xc,yc,zc - length =0. + length = 0. center_pix_int0 = -9999 + ! compute average clay/sand + if(ktot /= 0) then ! There should be some data pixels if(ktot > ktop) then ! Have both layers if(ktop > 0) then ! There are data in top layer - xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop + 1 : ktot)))/real(ktot - ktop) - yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop + 1 : ktot)))/real(ktot - ktop) + xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop+1 : ktot)))/real(ktot - ktop) + yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop+1 : ktot)))/real(ktot - ktop) else ! There are no data in top layer xc = sf*sum(real(x(1:ktot)))/real(ktot) @@ -4831,7 +5133,7 @@ INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) xc = sf*sum(real(x(1:ktot)))/real(ktot) yc = sf*sum(real(y(1:ktot)))/real(ktot) endif - zc = 100. - xc - yc + zc = 100. - xc - yc ! silt [percent] endif mindist=100000.*100000. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 index 76dba0fc5..fd381b50c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 @@ -3586,6 +3586,16 @@ SUBROUTINE create_model_para_woesten (Maskfile) !c------------------------------------------------------------------------- + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + if(use_PEATMAP) then fname = trim(c_data)//'SoilClasses-SoilHyd-TauParam.peatmap' else From bfb3cd385b9d0bf2987ada2186a1f533c795a75f Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Tue, 3 May 2022 09:18:23 -0400 Subject: [PATCH 05/21] fixing bug in previous commit --- .../Utils/Raster/mod_process_hres_data.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 36a0415b0..11cb0a6a2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -4881,8 +4881,7 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) fname='clsm/catchment.def' open (10,file=fname,status='old',action='read',form='formatted') - -!obsolete20220502 read(10,*) maxcat + read(10,*) maxcat ! re-read header line !obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' !obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') From ef69e8496be5415424864a9a4a7f13c131855dd2 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Wed, 4 May 2022 06:03:14 -0400 Subject: [PATCH 06/21] additional comments; fixed non-zero-diff change in penultimate commit --- .../Utils/Raster/create_README.csh | 26 ++++++---- .../Utils/Raster/mkCatchParam.F90 | 31 +++++++---- .../Utils/Raster/mod_process_hres_data.F90 | 51 ++++++++++++------- 3 files changed, 70 insertions(+), 38 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh index 88c5384cb..64ce22790 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh @@ -1575,18 +1575,26 @@ APPENDIX I - mkCatchParam tag, input options, and log _EOF2_ -cat << _EOF_ > clsm/back - -===================================================================================== -================================ END OF README FILE ================================ -===================================================================================== - -_EOF_ +# Do NOT append "END OF README FILE" here. This csh script does not know +# the return status of the Fortran executables. If a Fortran executable +# stops prematurely, the README file should not look finished. +# Maybe proper error handling can be added in the future. +# -reichle, 3 May 2022 + +###cat << _EOF_ > clsm/back +### +###===================================================================================== +###================================ END OF README FILE ================================ +###===================================================================================== +### +###_EOF_ sed -e "s/============================================================/ /g" clsm/mkCatchParam.log > clsm/log -cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back >> clsm/README +###cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back >> clsm/README +cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log >> clsm/README -/bin/rm clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back +###/bin/rm clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back +/bin/rm clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log ################################################################################# ## Plotting maps of fixed parameters and making movies of seasonal parameters ## diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index 754859c59..877a3c7ec 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -217,6 +217,15 @@ PROGRAM mkCatchParam inquire(file='clsm/catch_params.nc4', exist=file_exists) if (.not.file_exists) CALL open_landparam_nc4_files + ! ****************************************************************************** + ! + ! IMPORTANT: The top-level make_bcs script should not allow this program to + ! run when ./clsm/ exists. Consequently, across "Steps [xx]" below, + ! the "inquire()" statements should be obsolete, and the case + ! "Using existing file" should never happen. + ! + ! ****************************************************************************** + ! Creating catchment.def ! ---------------------- @@ -371,7 +380,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a)')' --> ', trim(fname_tmp) inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' if (trim(LAIBCS) == 'GSWP2') then call process_gswp2_veg (nc,nr,regrid,'grnFrac',gridnamer) else @@ -390,7 +399,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a)')' --> ', trim(fname_tmp) inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' redo_modis = .true. if (trim(LAIBCS) == 'GSWP2') call process_gswp2_veg (nc,nr,regrid,'LAI',gridnamer) @@ -439,7 +448,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a)')' --> ', trim(fname_tmp) inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' call gimms_clim_ndvi (nc,nr,gridnamer) write (log_file,'(a)')' Done.' else @@ -482,11 +491,13 @@ PROGRAM mkCatchParam endif if(MODALB == 'MODIS2') then - fname_tmp = 'clsm/AlbMap.WS.8-day.tile.0.7_5.0.dat' - write (log_file,'(a,a)')' --> ', trim(fname_tmp) - inquire(file=trim(fname_tmp), exist=file_exists) - if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + fname_tmp = 'clsm/AlbMap.WS.8-day.tile.0.3_0.7.dat' + fname_tmp2 = 'clsm/AlbMap.WS.8-day.tile.0.7_5.0.dat' + write (log_file,'(a,a,a,a)')' --> ', trim(fname_tmp), ', ', trim(fname_tmp2) + inquire(file=trim(fname_tmp ), exist=file_exists ) + inquire(file=trim(fname_tmp2), exist=file_exists2) + if ((.not.file_exists).or.(.not.file_exists2)) then + write (log_file,'(a)')' Creating files...' call modis_alb_on_tiles_high (43200,21600,maparc30,MODALB,gridnamer) write (log_file,'(a)')' Done.' else @@ -515,7 +526,7 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp2), exist=file_exists2) if ((redo_modis).or.(.not.file_exists).or.(.not.file_exists2)) then ! if(.not.F25Tag) then - write (log_file,'(a)')' Creating files...' + write (log_file,'(a)')' Creating files... (resolution will be added to file name later)' call modis_scale_para_high (ease_grid,MODALB,gridnamet) ! else ! This option is for legacy sets like Fortuna 2.1 @@ -629,7 +640,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' call CLM45_clim_parameters (nc,nr,gridnamer) write (log_file,'(a)')' Done.' else diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 11cb0a6a2..58135aa62 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -4339,7 +4339,7 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ! -------------------------------------------------------------------- ! - ! Read Woesten Soil Parameters and CLSM tau parameters for soil classes (1:253) + ! Read Woesten soil parameters and CLSM tau parameters for soil classes (1:253) allocate(a_sand (1:n_SoilClasses)) allocate(a_clay (1:n_SoilClasses)) @@ -4379,7 +4379,7 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) action = 'read') read (11,'(a)')fout ! read header line - do n =1,n_SoilClasses + do n =1,n_SoilClasses read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) @@ -4396,9 +4396,9 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. - if(n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n - if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n - if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n + if( n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n + if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n + if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n end do ! n=1,n_SoilClasses @@ -4406,8 +4406,8 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ! ------------------------------------------------------------ ! - ! When Woesten Soil Parameters are not available for a particular Soil Class, - ! as defined by "tiny" triangles in HWSD soil triangle, Woesten Soil + ! When Woesten soil parameters are not available for a particular soil class, + ! as defined by "tiny" triangles in HWSD soil triangle, Woesten soil ! parameters from the nearest available "tiny" triangle will be substituted. ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). @@ -4567,10 +4567,10 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n cFamily = 0. - factor = 1. +!! factor = 1. do j=1,i - ! if(j <= i) factor = 1. + if(j <= i) factor = 1. if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor @@ -4579,14 +4579,16 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) - if (.not. use_PEATMAP) then +!! if (.not. use_PEATMAP) then ! assign dominant *top* layer org soil class (even if only a minority of the contributing ! raster grid cells is peat) if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) - else +!! else + + if (use_PEATMAP) then ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) @@ -4619,7 +4621,8 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ! "where (oc_sub*sf >= cF_lim(4)) " ! " oc_sub = NINT(8./sf) " ! "endwhere " - ! For PEATMAP, the maxloc statement below should therefore result in o_clp = 1, 2, or 3 only (?) + ! For PEATMAP, in most cases the maxloc statement below should therefore result in o_clp = 1, 2, or 3 only, + ! but orgC from the top layer pushes the profile average orgC above cF_lim(4) again, then o_clp=4 is possible. if (sum(cFamily) == 0.) o_clp = 1 if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) @@ -4895,24 +4898,34 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then ! if com-layer has data, the issue is only with top-layer - ! ------------------------------------------------------- if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) - ! if there is nothing, look for the neighbor - ! ------------------------------------------ - + ! if there is nothing, look for the neighbor + ! + ! ^ + ! | + ! | The comment above seems wrong; could have soil_class_top(n)>=1, unless + ! earlier soil_class_com was set equal to soil_class_top whenever + ! soil_class_top was available and soil_class_com was not. + if (soil_class_com (n) == -9999) then + + ! Look for neighbor j (regardless of soil_class_top) and set both + ! soil_class_com(n) and soil_class_top(n) equal to the neighbor's + ! soil_class_com(j). + do k = 1, maxcat j = 0 i1 = n - k i2 = n + k - if((i1 >= 1).and.(soil_class_com (i1) >=1)) j = i1 - if((i2 <=maxcat).and.(soil_class_com (i2) >=1)) j = i2 + if((i1 >= 1).and.(soil_class_com (i1) >=1)) j = i1 ! tentatively use "lower" neighbor unless out of range + if((i2 <=maxcat).and.(soil_class_com (i2) >=1)) j = i2 ! "upper" neighbor prevails unless out of range if (j > 0) then soil_class_com (n) = soil_class_com (j) - soil_class_top (n) = soil_class_com (n) + !soil_class_top (n) = soil_class_com (n) + soil_class_top (n) = soil_class_com (j) ! should be faster/safer than usin gsoil_class_com(n) grav_vec(n) = grav_vec(j) soc_vec(n) = soc_vec (j) poc_vec(n) = poc_vec (j) From 63e815cf1840e4d57d7d24eab14084dcc7c27ead Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 11 May 2022 13:41:32 -0400 Subject: [PATCH 07/21] further clean up CLM4.5_veg_typs_fracs --- .../Utils/Raster/clsm_plots.pro | 439 +---------- .../Utils/Raster/create_README.csh | 34 +- .../Utils/Raster/make_bcs | 4 - .../Utils/Raster/mkCatchParam.F90 | 31 +- .../Utils/Raster/mod_process_hres_data.F90 | 741 +----------------- 5 files changed, 46 insertions(+), 1203 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro index 8111bbacb..f6d40749b 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro @@ -323,8 +323,7 @@ endfor close,1 clm_file = '../CLM_veg_typs_fracs' -clm45_file = '../CLM4.5_veg_typs_fracs' -if (file_test (clm_file) or file_test (clm45_file)) then begin +if (file_test (clm_file)) then begin endif else begin cti_mean = 0.961*cti_mean - 1.957 endelse @@ -345,21 +344,13 @@ cti_skew = 0. plot_mosaic, ncat, tile_id clm_file = '../CLM_veg_typs_fracs' -clm45_file = '../CLM4.5_veg_typs_fracs' -if (file_test (clm_file) or file_test (clm45_file)) then begin +if (file_test (clm_file)) then begin ;spawn, "/bin/cp /discover/nobackup/smahanam/GEOS5_misc/mask/images/ESA_LandCover_mask.jpg ." -if (file_test (clm_file)) then begin -plot_clm , ncat, tile_id -plot_carbon, ncat, tile_id -endif - -if (file_test (clm45_file)) then begin -plot_clm45 , ncat, tile_id -plot_carbon45, ncat, tile_id -endif + plot_clm , ncat, tile_id + plot_carbon, ncat, tile_id ; Now plot Ndep, T2m and SoilAlb ; ------------------------------ @@ -381,31 +372,31 @@ endif a6 = 0. a7 = 0. -openr,1,filename + openr,1,filename -for i = 0l,ncat -1l do begin - readf,1,a1, a2, a3, a4, a5, a6, a7 - ndep (i) = a1 - visdr(i) = a2 - visdf(i) = a3 - nirdr(i) = a4 - nirdf(i) = a5 - t2mm (i) = a6 - t2mp (i) = a7 + for i = 0l,ncat -1l do begin + readf,1,a1, a2, a3, a4, a5, a6, a7 + ndep (i) = a1 + visdr(i) = a2 + visdf(i) = a3 + nirdr(i) = a4 + nirdf(i) = a5 + t2mm (i) = a6 + t2mp (i) = a7 -endfor + endfor -close,1 -plot_three_vars2, ncat, tile_id, ndep, t2mm, t2mp -plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF + close,1 + plot_three_vars2, ncat, tile_id, ndep, t2mm, t2mp + plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF -ndep = 0. -visdr = 0. -visdf = 0. -nirdr = 0. -nirdf = 0. -t2mm = 0. -t2mp = 0. + ndep = 0. + visdr = 0. + visdf = 0. + nirdr = 0. + nirdf = 0. + t2mm = 0. + t2mp = 0. endif @@ -628,204 +619,6 @@ make_movies, ncat, vec2grid, 'MODIS-NIR' END -; ============================================================================== -; CLM45-Carbon classes -; ============================================================================== - -PRO plot_carbon45,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,4) -clm_grid = intarr (im,jm,4) - -filename = '../CLM4.5_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 -v3= 0 -v4 =0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v1,v2,v3,v4,fr,fr,fr,fr,v,v - clm_type(i,0) = v1 - clm_type(i,1) = v2 - clm_type(i,2) = v3 - clm_type(i,3) = v4 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 25] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,234,220,201,185,165,145,125,105, 85, 60, 40] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,234,220,201,185,165,145,125,105, 85, 60, 40] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,234,220,201,185,165,145,125,105, 85, 60, 40] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(27) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'C3CROP'; 18 c3_crop -clm_name(18) = 'C3IRR' ; 19 c3_irrigated -clm_name(19) = 'CORN' ; 20 corn -clm_name(20) = 'ICORN' ; 21 irrigated corn -clm_name(21) = 'STCER' ; 22 spring temperate cereal -clm_name(22) = 'ISTCER'; 23 irrigated spring temperate cereal -clm_name(23) = 'WTCER' ; 24 winter temperate cereal -clm_name(24) = 'IWTCER'; 25 irrigated winter temperate cereal -clm_name(25) = 'SOYB' ; 26 soybean -clm_name(26) = 'ISOYB' ; 27 irrigated soybean - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - ; ============================================================================== ; CLM-Carbon classes ; ============================================================================== @@ -1016,188 +809,6 @@ Write_JPEG, 'CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 END -; ============================================================================== -; CLM4.5 classes -; ============================================================================== - -PRO plot_clm45,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,2) -clm_grid = intarr (im,jm,2) - -filename = '../CLM4.5_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v,v,v,v,fr,fr,fr,fr,v1,v2 - clm_type(i,0) = v1 - clm_type(i,1) = v2 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [255,106,202,251, 0, 29, 77,109,142,233,255,255,127,164,217,234,220,201,185,165,145,125,105, 85, 60, 40] -g_in = [245, 91,178,154, 85,115,145,165,185, 23,131,191, 39, 53, 72,234,220,201,185,165,145,125,105, 85, 60, 40] -b_in = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0, 0, 4, 3, 1,234,220,201,185,165,145,125,105, 85, 60, 40] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(25) -clm_name( 0) = 'BARE' ; 1 bare -clm_name( 1) = 'NLEt' ; 2 needleleaf evergreen temperate tree -clm_name( 2) = 'NLEB' ; 3 needleleaf evergreen boreal tree -clm_name( 3) = 'NLDB' ; 4 needleleaf deciduous boreal tree -clm_name( 4) = 'BLET' ; 5 broadleaf evergreen tropical tree -clm_name( 5) = 'BLEt' ; 6 broadleaf evergreen temperate tree -clm_name( 6) = 'BLDT' ; 7 broadleaf deciduous tropical tree -clm_name( 7) = 'BLDt' ; 8 broadleaf deciduous temperate tree -clm_name( 8) = 'BLDB' ; 9 broadleaf deciduous boreal tree -clm_name( 9) = 'BLEtS'; 10 broadleaf evergreen temperate shrub -clm_name(10) = 'BLDtS'; 11 broadleaf deciduous temperate shrub -clm_name(11) = 'BLDBS'; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass -clm_name(14) = 'WC4G' ; 15 warm c4 grass -clm_name(15) = 'C3CROP'; 16 c3_crop -clm_name(16) = 'C3IRR' ; 17 c3_irrigated -clm_name(17) = 'CORN' ; 18 corn -clm_name(18) = 'ICORN' ; 19 irrigated corn -clm_name(19) = 'STCER' ; 20 spring temperate cereal -clm_name(20) = 'ISTCER'; 21 irrigated spring temperate cereal -clm_name(21) = 'WTCER' ; 22 winter temperate cereal -clm_name(22) = 'IWTCER'; 23 irrigated winter temperate cereal -clm_name(23) = 'SOYB' ; 24 soybean -clm_name(24) = 'ISOYB' ; 25 irrigated soybean - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - ; ============================================================================== ; CLM classes ; ============================================================================== diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh index 64ce22790..541b9de5a 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh @@ -424,7 +424,7 @@ cat << _EOI_ > clsm/intro 3.2 Data files and images 3.2.1 Mosaic vegetation types and fractions 3.2.2 vegdyn input data (mosaic primary type, canopy height, and roughness) for GEOS - 3.2.3 CLM/CLM4.5 and CLM/CLM4.5-carbon vegetation types and fractions + 3.2.3 CLM and CLM-carbon vegetation types and fractions 3.2.4 CLM Nitrogen Deposition, annual mean T2m, soil back ground albedo 3.2.5 CLM4.5 ABM, PEATF, GDP, HDM, and soil field capacity 3.2.6 CLM4.5 lightening frequency climatology @@ -1043,8 +1043,8 @@ _EOV1_ if( $MYMASK == GEOS5_10arcsec_mask | $MYMASK == GEOS5_10arcsec_mask.nc | $MYMASK == GEOS5_10arcsec_mask_freshwater-lakes.nc ) then cat << _EOV2_ > clsm/veg2 - 3.2.3 CLM/CLM4.5, CLM/CLM4.5-carbon, CLM4.5 and CLM4.5-carbon vegetation types and fractions - file names: CLM_veg_typs_fracs and CLM4.5_veg_typs_fracs + 3.2.3 CLM and CLM-carbon vegetation types and fractions + file names: CLM_veg_typs_fracs do n = 1, ${NTILES} read ([UNIT],'(2I10,4I3,4f7.2,2I3,2f7.2)') & tile_index, pfaf_code, & @@ -1057,29 +1057,28 @@ cat << _EOV2_ > clsm/veg2 (1) tile_index [-] number (2) pfaf_code [-] ${pfaf_des} (3) CLM-C_pt1 [-] CLM-Carbon primary type 1 - [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg and plots/CLM4.5-Carbon_PRIM_veg_typs.jpg"] + [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] (4) CLM-C_pt2 [-] CLM-Carbon primary type 2 (moisture stressed only) - [Figure 7b : bottom panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg and plots/CLM4.5-Carbon_PRIM_veg_typs.jpg"] + [Figure 7b : bottom panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] (5) CLM-C_st1 [-] CLM-Carbon secondary type 1 - [Figure 8a : top panel of "plots/CLM-Carbon_SEC_veg_typs.jpg and plots/CLM4.5-Carbon_SEC_veg_typs.jpg"] + [Figure 8a : top panel of "plots/CLM-Carbon_SEC_veg_typs.jpg"] (6) CLM-C_st2 [-] CLM-Carbon secondary type 2 (moisture stressed only) - [Figure 8b : bottom panel of "plots/CLM-Carbon_SEC_veg_typs.jpg and plots/CLM4.5-Carbon_SEC_veg_typs.jpg"] + [Figure 8b : bottom panel of "plots/CLM-Carbon_SEC_veg_typs.jpg"] (7) CLM-C_pf1 [-] CLM-Carbon fraction of 1st primary type (8) CLM-C_pf2 [-] CLM-Carbon fraction of 2nd primary type (moisture stressed only) (9) CLM-C_sf1 [-] CLM-Carbon fraction of 1st secondary type (10)CLM-C_sf2 [-] CLM-Carbon fraction of 2nd secondary type (moisture stressed only) (11)CLM_pt [-] CLM primary type - [Figure 9 : "plots/CLM_PRIM_veg_typs.jpg and plots/CLM4.5_PRIM_veg_typs.jpg"] + [Figure 9 : "plots/CLM_PRIM_veg_typs.jpg"] (12)CLM_st [-] CLM secondary type - [Figure 10: "plots/CLM_SEC_veg_typs.jpg and plots/CLM4.5_SEC_veg_typs.jpg"] + [Figure 10: "plots/CLM_SEC_veg_typs.jpg"] (13)CLM_pf [-] CLM fraction of primary type (14)CLM_sf [-] CLM fraction of secondary type - Please see below Table 2 for CLM (CLM4.5) and CLM-Carbon (CLM4.5-Carbon) land cover classification + Please see below Table 2 for CLM and CLM-Carbon land cover classification =================================================================================== - Land Cover CLM (CLM4.5) CLM-Carbon Map - (CLM4.5-Carbon) + Land Cover CLM CLM-Carbon Map Class Class Legend ----------------------------------------------------------------------------------- @@ -1103,20 +1102,9 @@ cat << _EOV2_ > clsm/veg2 Warm c4 grass [moisture stress only] - 17 WC4Gm Crop 16 18 CROP (-) Crop [moisture stress only] - 19 CROPm(-) - (C3_crop) (16) (18) C3CROP - (C3_irrigated) (17) (19) C3IRR - (Corn) (18) (20) CORN - (Irrigated corn) (19) (21) ICORN - (Spring temperate cereal) (20) (22) STCER - (Irrigated spring temperate cereal) (21) (23) ISTCER - (winter temperate cereal) (22) (24) WTCER - (Irrigated winter temperate cereal) (23) (25) IWTCER - (Soybean) (24) (26) SOYB - (Irrigated Soybean) (25) (27) ISOYB Water 17 - ----------------------------------------------------------------------------------- Table 2: CLM and CLM-Carbon land cover classification description. - CLM-4.5 and CLM-4.5-Carbon types are in brackets. 3.2.4 Nitrogen Deposition, annual mean 2m Tair, soil back gorund albedo file name: CLM_Ndep_SoilAlb diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs index e21883729..fb81482ac 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs @@ -819,7 +819,6 @@ cd ../ AlbMap* \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ @@ -1059,7 +1058,6 @@ cd ../ AlbMap* \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ @@ -1224,7 +1222,6 @@ cd ../ AlbMap* \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ @@ -1391,7 +1388,6 @@ cd ../ pfaf_fractions.dat \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ Grid2Catch_TransferData.nc \ CLM_NDep_SoilAlb_T2m \ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index 877a3c7ec..2186fac29 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -293,19 +293,6 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 05: Vegetation types using ESA land cover (CatchCNCLM45)' - fname_tmp = 'clsm/CLM4.5_veg_typs_fracs' - write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' - inquire(file=trim(fname_tmp), exist=file_exists) - if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' - call ESA2CLM_45 (nc,nr,gridnamer) - write (log_file,'(a)')' Done.' - else - write (log_file,'(a)')' Using existing file.' - endif - write (log_file,'(a)')' ' - else tmpstring = 'Step 03: Vegetation types using IGBP SiB2 land cover (MOSAIC/Catch)' @@ -345,7 +332,7 @@ PROGRAM mkCatchParam ! creating mapping arrays if necessary - tmpstring = 'Step 06: Vegetation climatologies' + tmpstring = 'Step 05: Vegetation climatologies' write (log_file,'(a,a,a)') trim(tmpstring),' ', trim(LAIBCS) if((trim(LAIBCS) == 'MODGEO').or.(trim(LAIBCS) == 'GEOLAND2')) then @@ -466,7 +453,7 @@ PROGRAM mkCatchParam ! MODIS1 data on native grid and produces 8/16-day MODIS Albedo climatology - tmpstring = 'Step 07: Albedo climatologies' + tmpstring = 'Step 06: Albedo climatologies' write (log_file,'(a,a,a)') trim(tmpstring),' ', trim(MODALB) if(MODALB == 'MODIS1') then @@ -513,7 +500,7 @@ PROGRAM mkCatchParam ! --------------------------------------------- - tmpstring = 'Step 08: Albedo scale factors' + tmpstring = 'Step 07: Albedo scale factors' write (log_file,'(a,a,a)') trim(tmpstring),' ', trim(MODALB) ! NOTE: There are two files with albedo scale factors: "visdf.dat" and "nirdf.dat". @@ -562,7 +549,7 @@ PROGRAM mkCatchParam ! 1) NGDC soil properties, 2) HWSD-STATSGO2 Soil Properties ! --------------------------------------------------------------------- - tmpstring = 'Step 09: Soil parameters ' // trim(SOILBCS) + tmpstring = 'Step 08: Soil parameters ' // trim(SOILBCS) fname_tmp = 'clsm/soil_param.first' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -579,7 +566,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 10: CLSM model parameters ' // trim(SOILBCS) + tmpstring = 'Step 09: CLSM model parameters ' // trim(SOILBCS) fname_tmp = 'clsm/ar.new' fname_tmp2 = 'clsm/bf.dat' fname_tmp3 = 'clsm/ts.dat' @@ -608,7 +595,7 @@ PROGRAM mkCatchParam write (log_file,'(a)')' Uncomment associated lines in source to generate 7.5 minute raster file.' write (log_file,'(a)')' ' - tmpstring = 'Step 11: CatchCNCLM40 NDep T2m SoilAlb parameters' + tmpstring = 'Step 10: CatchCNCLM40 NDep T2m SoilAlb parameters' fname_tmp = 'clsm/CLM_NDep_SoilAlb_T2m' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' ! create this file only if matching veg types file already exists @@ -622,7 +609,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 12: CatchCNCLM45 abm peatf gdp hdm fc parameters' + tmpstring = 'Step 11: CatchCNCLM45 abm peatf gdp hdm fc parameters' fname_tmp = 'clsm/CLM4.5_abm_peatf_gdp_hdm_fc' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -635,7 +622,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 13: CatchCNCLM45 lightning frequency' + tmpstring = 'Step 12: CatchCNCLM45 lightning frequency' fname_tmp = 'clsm/lnfm.dat' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -648,7 +635,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 14: Country and state codes' + tmpstring = 'Step 13: Country and state codes' fname_tmp = 'clsm/country_and_state_code.data' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 58135aa62..96fa49bc7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -27,7 +27,7 @@ MODULE process_hres_data public :: soil_para_hwsd,hres_lai,hres_gswp2, merge_lai_data, grid2tile_modis6 public :: modis_alb_on_tiles_high,modis_scale_para_high,hres_lai_no_gswp -public :: histogram, create_mapping, esa2mosaic , esa2clm, ESA2CLM_45 +public :: histogram, create_mapping, esa2mosaic , esa2clm public :: grid2tile_ndep_t2m_alb, CREATE_ROUT_PARA_FILE, map_country_codes, get_country_codes public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files @@ -55,745 +55,6 @@ MODULE process_hres_data contains ! ! --------------------------------------------------------------------- -! - - SUBROUTINE ESA2CLM_45 (nc, nr, gfile) - - implicit none - - integer , intent (in) :: nc, nr - character (*) :: gfile - - integer , parameter :: N_lon_clm = 7200, N_lat_clm = 3600, lsmpft = 25 - integer*2, allocatable, target, dimension (:,:) :: esa_veg - integer*2, pointer , dimension (:,:) :: subset - integer , allocatable, dimension (:) :: tile_id, i_esa2clm, j_esa2clm - integer :: i,j, k,n, status, ncid, varid, maxcat, dx,dy, esa_type, tid, cid, ii, jj - real :: dx_clm, dy_clm, x_min_clm (N_lon_clm), y_min_clm (N_lat_clm), clm_fracs(lsmpft) - real :: minlon,maxlon,minlat,maxlat,tile_lat, scale, ftot - integer :: cpt1, cpt2, cst1, cst2 ! CLM-carbon types - real :: cpf1, cpf2, csf1, csf2 ! CLM-carbon fractions - DOUBLE PRECISION, allocatable, dimension (:) :: lon_esa, lat_esa - DOUBLE PRECISION :: EDGEN, EDGEE, EDGES, EDGEW - - REAL, ALLOCATABLE, DIMENSION (:,:,:) :: PCTPFT - integer, allocatable, dimension (:) :: density, loc_int - real , allocatable, dimension (:) :: loc_val - logical, allocatable, dimension (:) :: unq_mask - integer :: NBINS, NPLUS - integer, allocatable, dimension (:,:) :: clm_veg - integer :: esa_clm_veg (2) - real :: esa_clm_frac(2) - - ! These 2 values are assumed as same as they are in surfdata_0.23x0.31_simyr2000_c100406.nc - - EDGEW = -180. - EDGES = -90. - - ! Reading CLM pft data file - !-------------------------- - - ALLOCATE (PCTPFT (1:N_lon_clm, 1:N_lat_clm, 1:lsmpft)) - - status = NF_OPEN ('data/CATCH/CLM45/mksrf_24pftNT_landuse_rc2000_c121207.nc', NF_NOWRITE, ncid) - status = NF_INQ_VARID (ncid,'PCT_PFT',VarID) ; VERIFY_(STATUS) - - do k = 1, 25 ! Natural vegetation - status = NF_GET_VARA_REAL (ncid,VarID,(/1,1,k/),(/N_lon_clm, N_lat_clm, 1/),PCTPFT(:,:,k)) ; VERIFY_(STATUS) - end do - - status = NF_CLOSE(ncid) - - ! CLM 4_5 description (25) CLM45-carbon description (27) - ! ------------------------ ----------------------------- - - ! 'BARE' 1 bare (does not have bare soil) - ! 'NLEt' 2 needleleaf evergreen temperate tree 1 - ! 'NLEB' 3 needleleaf evergreen boreal tree 2 - ! 'NLDB' 4 needleleaf deciduous boreal tree 3 - ! 'BLET' 5 broadleaf evergreen tropical tree 4 - ! 'BLEt' 6 broadleaf evergreen temperate tree 5 - ! 'BLDT' 7 broadleaf deciduous tropical tree 6 - ! 'BLDt' 8 broadleaf deciduous temperate tree 7 - ! 'BLDB' 9 broadleaf deciduous boreal tree 8 - ! 'BLEtS' 10 broadleaf evergreen temperate shrub 9 - ! 'BLDtS' 11 broadleaf deciduous temperate shrub 10 broadleaf deciduous temperate shrub [moisture + deciduous] - ! 'BLDtSm' broadleaf deciduous temperate shrub 11 broadleaf deciduous temperate shrub [moisture stress only] - ! 'BLDBS' 12 broadleaf deciduous boreal shrub 12 - ! 'AC3G' 13 arctic c3 grass 13 - ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] - ! 'CC3Gm' cool c3 grass 15 cool c3 grass [moisture stress only] - ! 'WC4G' 15 warm c4 grass 16 warm c4 grass [moisture + deciduous] - ! 'WC4Gm' warm c4 grass 17 warm c4 grass [moisture stress only] - ! 'C3CROP' 16 c3_crop 18 - ! 'C3IRR' 17 c3_irrigated 19 - ! 'CORN' 18 corn 20 - ! 'ICORN' 19 irrigated corn 21 - ! 'STCER' 20 spring temperate cereal 22 - ! 'ISTCER' 21 irrigated spring temperate cereal 23 - ! 'WTCER' 22 winter temperate cereal 24 - ! 'IWTCER' 23 irrigated winter temperate cereal 25 - ! 'SOYB' 24 soybean 26 - ! 'ISOYB' 25 irrigated soybean 27 - -!** ! 'CROP' 16 crop 18 crop [moisture + deciduous] -!** ! 'CROPm' crop 19 crop [moisture stress only] -!** ! 17 water - - dx_clm = 360./N_lon_clm - dy_clm = 180./N_lat_clm - - do i = 1, N_lon_clm - x_min_clm (i) = (i-1)*dx_clm + EDGEW - end do - - do i = 1, N_lat_clm - y_min_clm (i) = (i-1)*dy_clm + EDGES - end do - - ! This data set is DE - !PCTPFT (1:N_lon_clm/2 ,:,:) = REAL (PCT_PFT_DBL(N_lon_clm/2 + 1: N_lon_clm,:,:)) - !PCTPFT (N_lon_clm/2 + 1: N_lon_clm,:,:) = REAL (PCT_PFT_DBL(1:N_lon_clm/2 ,:,:)) - - !DEALLOCATE (PCT_PFT_DBL) - - ! Find primary and secondary types in the CLM data file - ! ----------------------------------------------------- - - ! allocate (clm_veg (1:N_lon_clm,1:N_lat_clm,1:2)) - ! - ! do j = 1, N_lat_clm - ! do i = 1, N_lon_clm - ! if(maxval(PCT_PFT(i,j,:)) > 0.) then - ! clm_fracs = PCT_PFT(i,j,:) - ! if (maxval (clm_fracs) == 100.) then - ! clm_veg(i,j,:) = maxloc (clm_fracs) - ! else - ! clm_veg(i,j,0) = maxloc (clm_fracs) - ! clm_fracs (clm_veg(i,j,0)) = 0. - ! clm_veg(i,j,1) = maxloc (clm_fracs) - ! endif - ! else - ! clm_veg(i,j,:) = 17 - ! endif - ! end do - ! end do - - ! Reading ESA vegetation types - !----------------------------- - - allocate (esa_veg (1:nc_esa, 1: nr_esa)) - allocate (lon_esa (1:nc_esa)) - allocate (lat_esa (1:nr_esa)) - - status = NF_OPEN ('data/CATCH/ESA_GlobalCover.nc', NF_NOWRITE, ncid) - - if(status /=0) then - PRINT *, NF_STRERROR(STATUS) - print *, 'Problem with NF_OPEN','ESA_GlobalCover.nc' - stop - endif - - status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/nr_esa/),lat_esa) - status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/nc_esa/),lon_esa) - - do j = 1,nr_esa - status = NF_GET_VARA_INT2 (ncid,3,(/1,j/),(/nc_esa,1/),esa_veg(:,j)) - if(status /=0) then - PRINT *, NF_STRERROR(STATUS) - print *, 'Problem with NF_GET ESA_GlobalCover.nc : ', STATUS - stop - endif - end do - - status = NF_CLOSE(ncid) - - ! Find I,J of overlying CLM grid cells for each ESA pixel - !-------------------------------------------------------- - allocate (i_esa2clm (1:nc_esa)) - allocate (j_esa2clm (1:nr_esa)) - - do i = 1, N_lon_clm - where ((real(lon_esa) >= x_min_clm(i)).and.(real(lon_esa) < (x_min_clm(i) + dx_clm))) i_esa2clm= i - end do - - i_esa2clm(129545:nc_esa) = 1 - - do j = 1, N_lat_clm - where ((real(lat_esa) >= y_min_clm(j)).and.(real(lat_esa) < (y_min_clm(j) + dy_clm))) j_esa2clm= j - end do - - ! - ! Reading number of tiles - ! ----------------------- - - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (10, *) maxcat - - close (10, status = 'keep') - - ! - ! Loop through tile_id raster - ! ___________________________ - - - allocate (tile_id (1:nc )) - allocate (clm_veg (1:maxcat,1:lsmpft)) - clm_veg = 0. - - dx = nc_esa / nc - dy = nr_esa / nr - - open (10,file=trim(gfile)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - - ! read a row - - read(10)tile_id(:) - - do i = 1,nc - - ii = i_esa2clm ((i-1)*dx + dx/2) - jj = j_esa2clm ((j-1)*dy + dy/2) - - if((tile_id (i) >= 1).and.(tile_id(i) <= maxcat)) then - - if (associated (subset)) NULLIFY (subset) - subset => esa_veg((i-1)*dx +1 :i*dx, (j-1)*dy +1:j*dy) - NPLUS = count(subset >= 1 .and. subset <= 230) - - if(NPLUS > 0) then - allocate (loc_int (1:NPLUS)) - allocate (unq_mask(1:NPLUS)) - loc_int = pack(subset,mask = (subset >= 1 .and. subset <= 230)) - call MAPL_Sort (loc_int) - unq_mask = .true. - do n = 2,NPLUS - unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) - end do - NBINS = count(unq_mask) - - allocate(loc_val (1:NBINS)) - allocate(density (1:NBINS)) - loc_val = 1.*pack(loc_int,mask =unq_mask) - call histogram (size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset)) - - do k = 1, nbins - - if (density (k) > 0) then - - esa_type = int (loc_val(k)) - - ! if (esa_type == 10) clm_veg (tile_id(i), 17) = 1.* density(k) ! lakes inland water - - if ((esa_type == 11).or. (esa_type == 14).or.(esa_type == 20).or. (esa_type == 190)) then - - ! ESA type 11: Post-flooding or irrigated croplands - ! ESA type 14: Rainfed croplands - ! ESA type 20: Mosaic Cropland (50-70%) / Vegetation (grassland, shrubland, forest) (20-50%) - ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) - - if(sum(PCTPFT(ii,jj,16:25)) > 0.) then - do n = 16,25 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,16:25)) - end do - else - clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) - endif - endif - - ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas - ! if (esa_type == 210) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ocean - ! if (esa_type == 220) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ice - ! gkw: bare soil excluded! only considering vegetated land - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 30) then - ! ESA type 30: Mosaic Vegetation (grassland, shrubland, forest) (50-70%) / Cropland (20-50%) - - if(sum(PCTPFT(ii,jj,16:25)) > 0.) then - do n = 16,25 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.5*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,16:25)) - end do - elseif(sum(PCTPFT(ii,jj,2:15)) > 0.) then - do n = 2, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.5* density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:15)) - enddo - else - clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.0* density(k) - endif - - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 40) then - ! ESA type 40: Closed to open (>15%) broadleaved evergreen and/or semi-deciduous forest (>5m) - - if(sum(PCTPFT(ii,jj,5:6)) > 0.) then - do n = 5, 6 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:6)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 5) = clm_veg (tile_id(i), 5) + 1.0* density(k) - else - clm_veg (tile_id(i), 6) = clm_veg (tile_id(i), 6) + 1.0* density(k) - endif - endif - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if ((esa_type == 50) .or. (esa_type == 60)) then - ! ESA type 50: Closed (>40%) broadleaved deciduous forest (>5m) - ! ESA type 60: Open (15-40%) broadleaved deciduous forest (>5m) - - if(sum(PCTPFT(ii,jj,7:9)) > 0.) then - do n = 7, 9 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:9)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 1.0* density(k) - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) - if(abs(y_min_clm(jj) + 0.5*dy_clm) >= 60.) clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 70) then - ! ESA type 70: Closed (>40%) needleleaved evergreen forest (>5m) - - if(sum(PCTPFT(ii,jj,2:3)) > 0.) then - do n = 2, 3 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:3)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 90) then - !ESA type 90: Open (15-40%) needleleaved deciduous or evergreen forest (>5m) - - if(sum(PCTPFT(ii,jj,2:4)) > 0.) then - do n = 2, 4 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:4)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 100) then - ! ESA type 100: Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m) - - if((sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) > 0.) then - do n = 2, 9 - if((n /= 5) .and. (n /= 6)) clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/(sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.5* density(k) - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) - elseif (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.5* density(k) - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.5* density(k) - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 0.5* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 110) then - ! ESA type 110: Mosaic Forest/Shrubland (50-70%) / Grassland (20-50%) - - if(sum(PCTPFT(ii,jj,7:12)) > 0.) then - do n = 7, 12 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.3* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.3* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.3* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.3* density(k) - end if - end if - - if(sum(PCTPFT(ii,jj,13:15)) > 0.) then - do n =13, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 0.4* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.4* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.4* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 120) then - ! ESA type 120: Mosaic Grassland (50-70%) / Forest/Shrubland (20-50%) - - if(sum(PCTPFT(ii,jj,7:12)) > 0.) then - do n = 7, 12 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.2* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.2* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.2* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.2* density(k) - end if - end if - - if(sum(PCTPFT(ii,jj,13:15)) > 0.) then - do n =13, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 0.6* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.6* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.6* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 130) then - ! Closed to open (>15%) shrubland (<5m) - - if(sum(PCTPFT(ii,jj,10:12)) > 0.) then - do n = 10,12 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:12)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.0* density(k) - else - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 140) then - ! ESA type 140: Closed to open (>15%) grassland - - if(sum(PCTPFT(ii,jj,13:15)) > 0.) then - do n = 13,15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) - end if - end if - end if - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 150) then - ! ESA type 150: Sparse (<15%) vegetation (woody vegetation, shrubs, grassland) - - if(sum(PCTPFT(ii,jj,10:15)) > 0.) then - do n = 10, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.0*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.5* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.5* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if((esa_type == 160) .or. (esa_type == 170)) then - ! ESA type 160: Closed (>40%) broadleaved forest regularly flooded - Fresh water ! ESA type 170: Closed (>40%) broadleaved semi-deciduous and/or evergreen forest regularly flooded - - if(sum(PCTPFT(ii,jj,5:9)) > 0.) then - do n = 5,9 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:9)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 5) = clm_veg (tile_id(i), 5) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 180) then - ! ESA type 180: Closed to open (>15%) vegetation (grassland, shrubland, woody vegetation) on regularly flooded or waterlogged soil - Fresh, brackish or saline water - - if(sum(PCTPFT(ii,jj,10:15)) > 0.) then - do n = 10,15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) - end if - end if - endif - endif - enddo - deallocate (loc_int,unq_mask,loc_val,density) - endif - end if - enddo - end do - - - deallocate (tile_id, PCTPFT,esa_veg,lon_esa,lat_esa,i_esa2clm,j_esa2clm) - close (10,status='keep') - - ! - ! Now create CLM-carbon_veg_fracs file - ! ------------------------------------ - - open (10,file='clsm/CLM4.5_veg_typs_fracs', & - form='formatted',status='unknown') - open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (11, *) maxcat - - do k = 1, maxcat - - read (11,'(i10,i8,5(2x,f9.4))') tid,cid,minlon,maxlon,minlat,maxlat - tile_lat = (minlat + maxlat)/2. - scale = (ABS (tile_lat) - 32.)/10. - scale = min (max(scale,0.),1.) - - esa_clm_veg = 0 - esa_clm_frac= 0. - - clm_fracs = clm_veg (k,:) - - if (sum (clm_fracs) == 0.) then ! gkw: no vegetated land found; set to BLDtS - esa_clm_veg (1) = 11 ! broadleaf deciduous shrub - esa_clm_frac(1) = 100. - else - esa_clm_veg (1) = maxloc(clm_fracs,1) - esa_clm_frac(1) = maxval(clm_fracs) - endif - - clm_fracs (esa_clm_veg (1)) = 0. - - if (sum (clm_fracs) == 0.) then ! gkw: no vegetated secondary type found, set to primary with zero fraction - esa_clm_veg (2) = esa_clm_veg (1) - esa_clm_frac(1) = 100. - esa_clm_frac(2) = 0. - else - esa_clm_veg (2) = maxloc(clm_fracs,1) - esa_clm_frac(1) = 100.*clm_veg (k,esa_clm_veg (1))/(clm_veg (k,esa_clm_veg (1)) + clm_veg (k,esa_clm_veg (2))) - esa_clm_frac(2) = 100. - esa_clm_frac(1) - end if - -! Now splitting CLM types for CLM-carbon model -! -------------------------------------------- - -! CLM types 2- 10,12,13 are not being splitted. -! ............................................. - - if ((esa_clm_veg (1) >= 2).and.(esa_clm_veg (1) <= 10)) then - CPT1 = esa_clm_veg (1) - 1 - CPT2 = esa_clm_veg (1) - 1 - CPF1 = esa_clm_frac(1) - CPF2 = 0. - endif - - if ((esa_clm_veg (2) >= 2).and.(esa_clm_veg (2) <= 10)) then - CST1 = esa_clm_veg (2) - 1 - CST2 = esa_clm_veg (2) - 1 - CSF1 = esa_clm_frac(2) - CSF2 = 0. - endif - -! ............................................. - - if ((esa_clm_veg (1) >= 12).and.(esa_clm_veg (1) <= 13)) then - CPT1 = esa_clm_veg (1) - CPT2 = esa_clm_veg (1) - CPF1 = esa_clm_frac(1) - CPF2 = 0. - endif - - if ((esa_clm_veg (2) >= 12).and.(esa_clm_veg (2) <= 13)) then - CST1 = esa_clm_veg (2) - CST2 = esa_clm_veg (2) - CSF1 = esa_clm_frac(2) - CSF2 = 0. - endif - -! CLM4_5 crop types - we don't split - - if ((esa_clm_veg (1) >= 16).and.(esa_clm_veg (1) <= 25)) then - CPT1 = esa_clm_veg (1) + 2 - CPT2 = esa_clm_veg (1) + 2 - CPF1 = esa_clm_frac(1) - CPF2 = 0. - endif - - if ((esa_clm_veg (2) >= 16).and.(esa_clm_veg (2) <= 25)) then - CST1 = esa_clm_veg (2) + 2 - CST2 = esa_clm_veg (2) + 2 - CSF1 = esa_clm_frac(2) - CSF2 = 0. - endif - -! Now splitting (broadleaf deciduous temperate shrub ) -! ............. - - if (esa_clm_veg (1) == 11) then - CPT1 = 10 - CPT2 = 11 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 11) then - CST1 = 10 - CST2 = 11 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif - -! ............. (cool c3 grass) - - if (esa_clm_veg (1) == 14) then - CPT1 = 14 - CPT2 = 15 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 14) then - CST1 = 14 - CST2 = 15 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif - -! ............. warm c4 grass - - if (esa_clm_veg (1) == 15) then - CPT1 = 16 - CPT2 = 17 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 15) then - CST1 = 16 - CST2 = 17 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif -! ............. -! CLM_4.5 : we don't splot crop type anymore 16 has become 16-25 and they are now 18-27 in catchment-CN -! if (esa_clm_veg (1) == 16) then -! CPT1 = 18 -! CPT2 = 19 -! CPF1 = esa_clm_frac(1) * scale -! CPF2 = esa_clm_frac(1) * (1. - scale) -! endif -! -! if (esa_clm_veg (2) == 16) then -! CST1 = 18 -! CST2 = 19 -! CSF1 = esa_clm_frac(2) * scale -! CSF2 = esa_clm_frac(2) * (1. - scale) -! endif - - ! fractions must sum to 1 - ! ----------------------- - ftot = cpf1 + cpf2 + csf1 + csf2 - - if(ftot /= 100.) then - cpf1 = 100. * cpf1 / ftot - cpf2 = 100. * cpf2 / ftot - csf1 = 100. * csf1 / ftot - csf2 = 100. * csf2 / ftot - endif - - write (10,'(2I10,4I3,4f7.2,2I3,2f7.2)') & - tid,cid,cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & - esa_clm_veg (1), esa_clm_veg (2), esa_clm_frac(1), esa_clm_frac(2) - end do - - close (10, status = 'keep') - close (11, status = 'keep') - - END SUBROUTINE ESA2CLM_45 - -! -! ------------------------------------------------------------------------------------------------ ! SUBROUTINE ESA2CLM (nc, nr, gfile) From 59356e93cfe29e2dc260efbb200bd4bf9dda5059 Mon Sep 17 00:00:00 2001 From: gmao-jkolassa Date: Fri, 13 May 2022 14:24:08 -0400 Subject: [PATCH 08/21] removed obsolete separate processing of CNCLM45 plant types and fractions; updated documentation --- .../Utils/mk_restarts/mk_GEOSldasRestarts.F90 | 100 ++---------------- 1 file changed, 11 insertions(+), 89 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 index da979d04b..f61d1c5c0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 @@ -1302,6 +1302,15 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) ! ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). ! output catchcn_internal_rst is nc4. + ! + ! CHANGE LOG: + ! + ! jkolassa, May 2022: Obsolete processing of CNCLM45 vegetation types/fractions is removed. + ! Separate processing of CNCLM40 and CNCLM45 PFTs was initially implemented, + ! as the underlying CLM4.0 and CLM4.5 models have different PFT distributions. + ! The decision was made to use the same (CLM4.0-based) PFT distribution in both + ! CNCLM40 and CNCLM45 and the obsolete processing of separate CNCLM45 types/fractions + ! was removed. implicit none real, intent (in) :: SURFLAY @@ -1309,9 +1318,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) character(*), intent (in) :: MODEL, DataDir, InRestart integer, optional, intent(out) :: rc real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) + real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) @@ -1346,10 +1353,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) allocate ( ity(ntiles), CanopH(ntiles) ) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) - allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) @@ -1441,7 +1445,6 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') if(clm45) then - open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') endif endif @@ -1474,10 +1477,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then - read (29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & - CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) - + if(clm45) then read (30, *) i, j, abm(n), peatf(n), & gdp(n), hdm(n), fc(n) endif @@ -1495,7 +1495,6 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLOSE (27, STATUS = 'KEEP') CLOSE (28, STATUS = 'KEEP') if(clm45) then - CLOSE (29, STATUS = 'KEEP') CLOSE (30, STATUS = 'KEEP') endif endif @@ -1557,35 +1556,6 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC_sf1(n) = fvg(3) CLMC_sf2(n) = fvg(4) - if(CLM45) then - ! CLM 45 - - CLMC45_pf1(n) = CLMC45_pf1(n) / 100. - CLMC45_pf2(n) = CLMC45_pf2(n) / 100. - CLMC45_sf1(n) = CLMC45_sf1(n) / 100. - CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - - fvg(1) = CLMC45_pf1(n) - fvg(2) = CLMC45_pf2(n) - fvg(3) = CLMC45_sf1(n) - fvg(4) = CLMC45_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC45_pf1(n) = fvg(1) - CLMC45_pf2(n) = fvg(2) - CLMC45_sf1(n) = fvg(3) - CLMC45_sf2(n) = fvg(4) - endif endif enddo @@ -1631,45 +1601,6 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif CLMC_sf2(n) = 0. endif - - if (clm45) then - ! CLM45 - if(CLMC45_pf1(n) <= 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) - CLMC45_pf1(n) = 0. - endif - - if(CLMC45_pf2(n) <= 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) - CLMC45_pf2(n) = 0. - endif - - if(CLMC45_sf1(n) <= 1.e-4) then - if(CLMC45_sf2(n) > 1.e-4) then - CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) - else - stop 'fveg3' - endif - CLMC45_sf1(n) = 0. - endif - - if(CLMC45_sf2(n) <= 1.e-4) then - if(CLMC45_sf1(n) > 1.e-4) then - CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) - else - stop 'fveg4' - endif - CLMC45_sf2(n) = 0. - endif - endif end do endif @@ -1740,15 +1671,6 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - if(CLM45) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'HDM' ), (/1/), (/NTILES/),HDM) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GDP' ), (/1/), (/NTILES/),GDP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PEATF' ), (/1/), (/NTILES/),PEATF) - endif - else STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'OLD_ITY'), (/1/), (/NTILES/),real(ITY)) endif From 7d33b4fb5f21c7c9713f58bfc3fcf6d018bc01f5 Mon Sep 17 00:00:00 2001 From: gmao-jkolassa Date: Fri, 13 May 2022 14:24:50 -0400 Subject: [PATCH 09/21] updated documentation about removed mapping to CLM4.5 PFTs --- .../Utils/Raster/mod_process_hres_data.F90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 96fa49bc7..07233e82d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -6,6 +6,15 @@ ! NGDC-HWSD-STATSGO merged soil data on their native grids 3-23-2012 ! Contact: Sarith Mahanama sarith.p.mahanama@nasa.gov ! Email : sarith.p.mahanama@nasa.gov +! +! CHANGE LOG: +! +! jkolassa May 2022: Obsolete mapping of ESA GlobCover data to CLM4.5 PFTs (subroutine ESA2CLM_45) is removed. +! Separate mappings for CNCLM40 and CNCLM45 were initially implemented, as +! the underlying CLM4.0 and CLM4.5 models have different plant functional types and +! distributions. The decision was made to use the same (CLM4.0-based) PFT +! distribution for both CNCLM40 and CNCLM45 and the obsolete mapping to CLM4.5 +! PFTs was removed. MODULE process_hres_data use rmTinyCatchParaMod @@ -111,7 +120,7 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) PCT_PFT_DBL(360:494,215:341,11) = PCT_PFT_DBL(360:494,215:341,11) + PCT_PFT_DBL(360:494,215:341, 7) PCT_PFT_DBL(360:494,215:341, 7) = 0. - ! CLM description (17) CLM-carbon description (19) + ! CLM description (17) CNCLM description (19) ! -------------------- -------------------------- ! 'BARE' 1 bare (does not have bare soil) @@ -641,10 +650,10 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) esa_clm_frac(2) = 100. - esa_clm_frac(1) end if -! Now splitting CLM types for CLM-carbon model +! Now splitting CLM types for CNCLM model ! -------------------------------------------- -! CLM types 2- 10,12,13 are not being splitted. +! CLM types 2- 10,12,13 are not being split. ! ............................................. if ((esa_clm_veg (1) >= 2).and.(esa_clm_veg (1) <= 10)) then From ebd2d6d2f1563f4c1faaa1c6dc8d2957c214f268 Mon Sep 17 00:00:00 2001 From: gmao-jkolassa Date: Fri, 13 May 2022 14:25:56 -0400 Subject: [PATCH 10/21] updated documentation about PFTs used in CNCLM40 and CNCLM45; changed instances of 'CLM-Carbon' to 'Catchment-CN' --- .../Utils/Raster/create_README.csh | 76 ++++++++++--------- 1 file changed, 40 insertions(+), 36 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh index 541b9de5a..76b659340 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh @@ -75,11 +75,15 @@ set toc_rout="`printf '\\n7. GLOBAL RUNOFF ROUTING MODEL DATA .................. arrays and on latitude (for differentiating certain types, such as Arctic c3 grass). \\n \ Bare soil from the ESA land cover classification is mapped into the broadleaf deciduous \\n \ shrub type, since bare soil is not an allowed type in our implementation.\\n \ +\\n \ + Initially, a separate mapping of the ESA land cover classification to the (17) CLM4 PFTs and \\n \ + (25) CLM4.5 PFTs was implemented. However, the decision was made later to use\\n \ + the same (CLM4-based) PFTs for both versions of the Catchment-CN model. Any processing \\n \ + specific to CLM4.5 PFTs was removed. \\n \ \\n \ For Catchment-CN, the stress deciduous types (crop and temperate shrubs/grass) utilized \\n \ by CLM4 is replaced by a mix of two sub-types, one that is seasonally deciduous (with a \\n \ - daylight trigger) and one that is not. Crop type has been further classified to 10 \\n \ - different types in CLM4.5, thus they were not sub-divided into further sub-types, however. \\n \ + daylight trigger) and one that is not. \\n \ Both sub-types are subject to moisture stress triggers\\n \ but not to temperature (freezing) stress triggers. The removal of the temperature stress \\n \ trigger eliminated unnatural swings in leaf carbon during brief temperature stress senescence\\n \ @@ -424,7 +428,7 @@ cat << _EOI_ > clsm/intro 3.2 Data files and images 3.2.1 Mosaic vegetation types and fractions 3.2.2 vegdyn input data (mosaic primary type, canopy height, and roughness) for GEOS - 3.2.3 CLM and CLM-carbon vegetation types and fractions + 3.2.3 CLM and Catchment-CN vegetation types and fractions 3.2.4 CLM Nitrogen Deposition, annual mean T2m, soil back ground albedo 3.2.5 CLM4.5 ABM, PEATF, GDP, HDM, and soil field capacity 3.2.6 CLM4.5 lightening frequency climatology @@ -1043,7 +1047,7 @@ _EOV1_ if( $MYMASK == GEOS5_10arcsec_mask | $MYMASK == GEOS5_10arcsec_mask.nc | $MYMASK == GEOS5_10arcsec_mask_freshwater-lakes.nc ) then cat << _EOV2_ > clsm/veg2 - 3.2.3 CLM and CLM-carbon vegetation types and fractions + 3.2.3 CLM and Catchment-CN vegetation types and fractions file names: CLM_veg_typs_fracs do n = 1, ${NTILES} read ([UNIT],'(2I10,4I3,4f7.2,2I3,2f7.2)') & @@ -1056,18 +1060,18 @@ cat << _EOV2_ > clsm/veg2 where for each tile: (1) tile_index [-] number (2) pfaf_code [-] ${pfaf_des} - (3) CLM-C_pt1 [-] CLM-Carbon primary type 1 + (3) CLM-C_pt1 [-] Catchment-CN primary type 1 [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] - (4) CLM-C_pt2 [-] CLM-Carbon primary type 2 (moisture stressed only) + (4) CLM-C_pt2 [-] Catchment-CN primary type 2 (moisture stressed only) [Figure 7b : bottom panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] - (5) CLM-C_st1 [-] CLM-Carbon secondary type 1 + (5) CLM-C_st1 [-] Catchment-CN secondary type 1 [Figure 8a : top panel of "plots/CLM-Carbon_SEC_veg_typs.jpg"] - (6) CLM-C_st2 [-] CLM-Carbon secondary type 2 (moisture stressed only) + (6) CLM-C_st2 [-] Catchment-CN secondary type 2 (moisture stressed only) [Figure 8b : bottom panel of "plots/CLM-Carbon_SEC_veg_typs.jpg"] - (7) CLM-C_pf1 [-] CLM-Carbon fraction of 1st primary type - (8) CLM-C_pf2 [-] CLM-Carbon fraction of 2nd primary type (moisture stressed only) - (9) CLM-C_sf1 [-] CLM-Carbon fraction of 1st secondary type - (10)CLM-C_sf2 [-] CLM-Carbon fraction of 2nd secondary type (moisture stressed only) + (7) CLM-C_pf1 [-] Catchment-CN fraction of 1st primary type + (8) CLM-C_pf2 [-] Catchment-CN fraction of 2nd primary type (moisture stressed only) + (9) CLM-C_sf1 [-] Catchment-CN fraction of 1st secondary type + (10)CLM-C_sf2 [-] Catchment-CN fraction of 2nd secondary type (moisture stressed only) (11)CLM_pt [-] CLM primary type [Figure 9 : "plots/CLM_PRIM_veg_typs.jpg"] (12)CLM_st [-] CLM secondary type @@ -1075,36 +1079,36 @@ cat << _EOV2_ > clsm/veg2 (13)CLM_pf [-] CLM fraction of primary type (14)CLM_sf [-] CLM fraction of secondary type - Please see below Table 2 for CLM and CLM-Carbon land cover classification + Please see below Table 2 for CLM and Catchment-CN land cover classification =================================================================================== - Land Cover CLM CLM-Carbon Map - Class Class Legend + Land Cover CLM Catchment-CN Map + Class Class Legend ----------------------------------------------------------------------------------- - Bare 1 - BARE - Needleleaf evergreen temperate tree 2 1 NLEt - Needleleaf evergreen boreal tree 3 2 NLEB - Needleleaf deciduous boreal tree 4 3 NLDB - Broadleaf evergreen tropical tree 5 4 BLET - Broadleaf evergreen temperate tree 6 5 BLEt - Broadleaf deciduous tropical tree 7 6 BLDT - Broadleaf deciduous temperate tree 8 7 BLDt - Broadleaf deciduous boreal tree 9 8 BLDB - Broadleaf evergreen temperate shrub 10 9 BLEtS - Broadleaf deciduous temperate shrub 11 10 BLDtS - Broadleaf deciduous temperate shrub[moisture stress only] - 11 BLDtSm - Broadleaf deciduous boreal shrub 12 12 BLDBS - Arctic c3 grass 13 13 AC3G - Cool c3 grass 14 14 CC3G - Cool c3 grass [moisture stress only] - 15 CC3Gm - Warm c4 grass 15 16 WC4G - Warm c4 grass [moisture stress only] - 17 WC4Gm - Crop 16 18 CROP (-) - Crop [moisture stress only] - 19 CROPm(-) + Bare 1 - BARE + Needleleaf evergreen temperate tree 2 1 NLEt + Needleleaf evergreen boreal tree 3 2 NLEB + Needleleaf deciduous boreal tree 4 3 NLDB + Broadleaf evergreen tropical tree 5 4 BLET + Broadleaf evergreen temperate tree 6 5 BLEt + Broadleaf deciduous tropical tree 7 6 BLDT + Broadleaf deciduous temperate tree 8 7 BLDt + Broadleaf deciduous boreal tree 9 8 BLDB + Broadleaf evergreen temperate shrub 10 9 BLEtS + Broadleaf deciduous temperate shrub 11 10 BLDtS + Broadleaf deciduous temperate shrub[moisture stress only] - 11 BLDtSm + Broadleaf deciduous boreal shrub 12 12 BLDBS + Arctic c3 grass 13 13 AC3G + Cool c3 grass 14 14 CC3G + Cool c3 grass [moisture stress only] - 15 CC3Gm + Warm c4 grass 15 16 WC4G + Warm c4 grass [moisture stress only] - 17 WC4Gm + Crop 16 18 CROP (-) + Crop [moisture stress only] - 19 CROPm(-) Water 17 - ----------------------------------------------------------------------------------- - Table 2: CLM and CLM-Carbon land cover classification description. + Table 2: CLM and Catchment-CN land cover classification description. 3.2.4 Nitrogen Deposition, annual mean 2m Tair, soil back gorund albedo file name: CLM_Ndep_SoilAlb From e2414386fe1a56edb893d27eac933fe377fceea1 Mon Sep 17 00:00:00 2001 From: gmao-jkolassa Date: Fri, 13 May 2022 14:26:39 -0400 Subject: [PATCH 11/21] changed instances of 'CLM-Carbon' to 'Catchment-CN' except in plot titles --- .../GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro index f6d40749b..2c2f0be71 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro @@ -620,7 +620,7 @@ make_movies, ncat, vec2grid, 'MODIS-NIR' END ; ============================================================================== -; CLM-Carbon classes +; Catchment-CN classes ; ============================================================================== PRO plot_carbon,ncat, tile_id From 76939123630615c2d4a5744bfc1f7ea797b44ef9 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 13 May 2022 15:38:24 -0400 Subject: [PATCH 12/21] a couple of minor edits to comments in mod_process_hres_data.F90 (inadvertently omitted from previous commit) --- .../Utils/Raster/mod_process_hres_data.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 58135aa62..aca2a32d4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -4559,7 +4559,7 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) ss_sand_all (1+i:2*i) = data_vec5(i1:i2) - ss_oc_all (1+i:2*i) = data_vec6(i1:i2) + ss_oc_all (1+i:2*i) = data_vec6(i1:i2) ! <-- oc_sub ! ----------------------------------------------------------------------- @@ -4621,8 +4621,10 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) ! "where (oc_sub*sf >= cF_lim(4)) " ! " oc_sub = NINT(8./sf) " ! "endwhere " - ! For PEATMAP, in most cases the maxloc statement below should therefore result in o_clp = 1, 2, or 3 only, - ! but orgC from the top layer pushes the profile average orgC above cF_lim(4) again, then o_clp=4 is possible. + ! For PEATMAP, the sub-layer weight of 2.33 should only count towards cFamily(1:3), and in most cases the + ! maxloc statement below should therefore result in o_clp = 1, 2, or 3 only. However, if the top-layer orgC + ! is peat for most contributing raster grid cells and the sub-layer orgC values are relatively evenly spread + ! over orgC classes 1, 2, and 3, then maxloc(cFamily) can result in o_clp=4. if (sum(cFamily) == 0.) o_clp = 1 if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) From 112fc5aa4c5885a0eaafb01d2f17d4589535b754 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 13 May 2022 15:52:36 -0400 Subject: [PATCH 13/21] changed file names of CatchCN veg class plots: CLM-Carbon_*.jpg --> CatchmentCN_*.jpg --- .../GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro index 2c2f0be71..a15739012 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro @@ -761,7 +761,7 @@ image24 = BytArr(3, 700, 1000) image24[0,*,*] = r[snapshot] image24[1,*,*] = g[snapshot] image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 +Write_JPEG, 'CatchmentCN_PRIM_veg_typs.jpg', image24, True=1, Quality=100 ; now plotting secondary thisDevice = !D.Name @@ -805,7 +805,7 @@ image24 = BytArr(3, 700, 1000) image24[0,*,*] = r[snapshot] image24[1,*,*] = g[snapshot] image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 +Write_JPEG, 'CatchmentCN_SEC_veg_typs.jpg', image24, True=1, Quality=100 END From 1decec25f352df7b4306377d5594227e5013c7a1 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 13 May 2022 16:18:20 -0400 Subject: [PATCH 14/21] minor clarifications in comments about removal of CLM4.5 veg class processing --- .../Utils/Raster/create_README.csh | 4 ++-- .../Utils/Raster/mod_process_hres_data.F90 | 19 +++++++++++-------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh index 76b659340..dda2457bb 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh @@ -76,9 +76,9 @@ set toc_rout="`printf '\\n7. GLOBAL RUNOFF ROUTING MODEL DATA .................. Bare soil from the ESA land cover classification is mapped into the broadleaf deciduous \\n \ shrub type, since bare soil is not an allowed type in our implementation.\\n \ \\n \ - Initially, a separate mapping of the ESA land cover classification to the (17) CLM4 PFTs and \\n \ + Initially, a separate mapping of the ESA land cover classification to the (17) CLM4.0 PFTs and \\n \ (25) CLM4.5 PFTs was implemented. However, the decision was made later to use\\n \ - the same (CLM4-based) PFTs for both versions of the Catchment-CN model. Any processing \\n \ + the same 17 (CLM4.0-based) PFTs for both CatchmentCNCLM40 and CatchmentCNCLM45. Any processing \\n \ specific to CLM4.5 PFTs was removed. \\n \ \\n \ For Catchment-CN, the stress deciduous types (crop and temperate shrubs/grass) utilized \\n \ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 07233e82d..24792c35b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -9,12 +9,15 @@ ! ! CHANGE LOG: ! -! jkolassa May 2022: Obsolete mapping of ESA GlobCover data to CLM4.5 PFTs (subroutine ESA2CLM_45) is removed. -! Separate mappings for CNCLM40 and CNCLM45 were initially implemented, as -! the underlying CLM4.0 and CLM4.5 models have different plant functional types and -! distributions. The decision was made to use the same (CLM4.0-based) PFT -! distribution for both CNCLM40 and CNCLM45 and the obsolete mapping to CLM4.5 -! PFTs was removed. +! jkolassa, reichle, May 2022: +! The bcs file "CLM4.5_veg_typs_fracs" was not used in CatchmentCNCLM45 and is no longer +! produced by make_bcs. +! Separate mappings from ESA GlobCover to CatchmentCNCLM40 and CatchmentCNCLM45 PFTs +! were initially implemented because the underlying CLM4.0 and CLM4.5 models have different +! plant functional types and distributions. Ultimately, the decision was made to use the same +! (CLM4.0-based) PFT distribution for both CatchmentCNCLM40 and CatchmentCNCLM45, and the +! obsolete mapping of ESA GlobCover data to CLM4.5 PFTs (subroutine ESA2CLM_45) was removed. + MODULE process_hres_data use rmTinyCatchParaMod @@ -120,8 +123,8 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) PCT_PFT_DBL(360:494,215:341,11) = PCT_PFT_DBL(360:494,215:341,11) + PCT_PFT_DBL(360:494,215:341, 7) PCT_PFT_DBL(360:494,215:341, 7) = 0. - ! CLM description (17) CNCLM description (19) - ! -------------------- -------------------------- + ! CLM description (17) CatchmentCNCLM description (19) + ! -------------------- ------------------------------ ! 'BARE' 1 bare (does not have bare soil) ! 'NLEt' 2 needleleaf evergreen temperate tree 1 From 69437299386381c1ca1ed14bcd877b4bc6acba06 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 13 May 2022 16:23:42 -0400 Subject: [PATCH 15/21] reverting previous commit for mk_GEOSldasRestarts.F90 because changes to files in the mk_restarts package should be made on the mk_restarts branch and PR, not on the make_bcs branch and PR --- .../Utils/mk_restarts/mk_GEOSldasRestarts.F90 | 100 ++++++++++++++++-- 1 file changed, 89 insertions(+), 11 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 index f61d1c5c0..da979d04b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 @@ -1302,15 +1302,6 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) ! ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). ! output catchcn_internal_rst is nc4. - ! - ! CHANGE LOG: - ! - ! jkolassa, May 2022: Obsolete processing of CNCLM45 vegetation types/fractions is removed. - ! Separate processing of CNCLM40 and CNCLM45 PFTs was initially implemented, - ! as the underlying CLM4.0 and CLM4.5 models have different PFT distributions. - ! The decision was made to use the same (CLM4.0-based) PFT distribution in both - ! CNCLM40 and CNCLM45 and the obsolete processing of separate CNCLM45 types/fractions - ! was removed. implicit none real, intent (in) :: SURFLAY @@ -1318,7 +1309,9 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) character(*), intent (in) :: MODEL, DataDir, InRestart integer, optional, intent(out) :: rc real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) + real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) + real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) + real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) @@ -1353,7 +1346,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) allocate ( ity(ntiles), CanopH(ntiles) ) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) + allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) + allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) + allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) @@ -1445,6 +1441,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') if(clm45) then + open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') endif endif @@ -1477,7 +1474,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then + if(clm45) then + read (29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & + CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) + read (30, *) i, j, abm(n), peatf(n), & gdp(n), hdm(n), fc(n) endif @@ -1495,6 +1495,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLOSE (27, STATUS = 'KEEP') CLOSE (28, STATUS = 'KEEP') if(clm45) then + CLOSE (29, STATUS = 'KEEP') CLOSE (30, STATUS = 'KEEP') endif endif @@ -1556,6 +1557,35 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC_sf1(n) = fvg(3) CLMC_sf2(n) = fvg(4) + if(CLM45) then + ! CLM 45 + + CLMC45_pf1(n) = CLMC45_pf1(n) / 100. + CLMC45_pf2(n) = CLMC45_pf2(n) / 100. + CLMC45_sf1(n) = CLMC45_sf1(n) / 100. + CLMC45_sf2(n) = CLMC45_sf2(n) / 100. + + fvg(1) = CLMC45_pf1(n) + fvg(2) = CLMC45_pf2(n) + fvg(3) = CLMC45_sf1(n) + fvg(4) = CLMC45_sf2(n) + + BARE = 1. + + DO NV = 1, NVEG + BARE = BARE - FVG(NV)! subtract vegetated fractions + END DO + + if (BARE /= 0.) THEN + IB = MAXLOC(FVG(:),1) + FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. + ENDIF + + CLMC45_pf1(n) = fvg(1) + CLMC45_pf2(n) = fvg(2) + CLMC45_sf1(n) = fvg(3) + CLMC45_sf2(n) = fvg(4) + endif endif enddo @@ -1601,6 +1631,45 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif CLMC_sf2(n) = 0. endif + + if (clm45) then + ! CLM45 + if(CLMC45_pf1(n) <= 1.e-4) then + CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) + CLMC45_pf1(n) = 0. + endif + + if(CLMC45_pf2(n) <= 1.e-4) then + CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) + CLMC45_pf2(n) = 0. + endif + + if(CLMC45_sf1(n) <= 1.e-4) then + if(CLMC45_sf2(n) > 1.e-4) then + CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) + else if(CLMC45_pf2(n) > 1.e-4) then + CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) + else if(CLMC45_pf1(n) > 1.e-4) then + CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) + else + stop 'fveg3' + endif + CLMC45_sf1(n) = 0. + endif + + if(CLMC45_sf2(n) <= 1.e-4) then + if(CLMC45_sf1(n) > 1.e-4) then + CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) + else if(CLMC45_pf2(n) > 1.e-4) then + CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) + else if(CLMC45_pf1(n) > 1.e-4) then + CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) + else + stop 'fveg4' + endif + CLMC45_sf2(n) = 0. + endif + endif end do endif @@ -1671,6 +1740,15 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) + if(CLM45) then + + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'HDM' ), (/1/), (/NTILES/),HDM) + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GDP' ), (/1/), (/NTILES/),GDP) + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PEATF' ), (/1/), (/NTILES/),PEATF) + endif + else STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'OLD_ITY'), (/1/), (/NTILES/),real(ITY)) endif From e39b8f9bf25ff99b85f5852f800f6bff02d092e5 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Mon, 16 May 2022 12:12:16 -0400 Subject: [PATCH 16/21] removing scaling with fpar --- .../GEOS_CatchCNCLM40GridComp.F90 | 400 +-------- .../GEOS_CatchCNCLM45GridComp.F90 | 402 +-------- .../utils/compute_FPAR_CDF_M09.F90 | 801 ----------------- .../Shared/GEOS_SurfaceGridComp.rc | 11 - .../Utils/Raster/CMakeLists.txt | 1 - .../comp_CATCHCN_AlbScale_parameters.F90 | 835 ------------------ .../Utils/Raster/make_bcs | 32 - .../Utils/Raster/mkCatchParam.F90 | 2 - 8 files changed, 14 insertions(+), 2470 deletions(-) delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index 32173c29d..5e95efd27 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -173,7 +173,7 @@ module GEOS_CatchCNCLM40GridCompMod end type OFFLINE_WRAP integer :: RUN_IRRIG, USE_ASCATZ0, Z0_FORMULATION, IRRIG_METHOD, AEROSOL_DEPOSITION, N_CONST_LAND4SNWALB -integer :: ATM_CO2, PRESCRIBE_DVG, SCALE_ALBFPAR,CHOOSEMOSFC +integer :: ATM_CO2, PRESCRIBE_DVG,CHOOSEMOSFC real :: SURFLAY ! Default (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params real :: CO2 @@ -297,13 +297,6 @@ subroutine SetServices ( GC, RC ) ! 3--Estimated LAI/SAI using anomalies at the beginning of the foeecast and climatological LAI/SAI call MAPL_GetResource (SCF, PRESCRIBE_DVG, label='PRESCRIBE_DVG:', DEFAULT=0 , __RC__ ) - ! SCALE_ALBFPAR: Scale CATCHCN ALBEDO and FPAR - ! 0-- NO scaling is performed - ! 1-- Scale albedo to match interannually varying MODIS NIRDF and VISDF anomaly - ! 2-- Scale albedo to match CDFs of model fPAR to MODIS CDFs of fPAR - ! 3-- Pefform above both 1 and 2 scalings - call MAPL_GetResource (SCF, SCALE_ALBFPAR, label='SCALE_ALBFPAR:', DEFAULT=0 , __RC__ ) - ! Global mean CO2 call MAPL_GetResource (SCF, CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) call MAPL_GetResource (SCF, CO2_YEAR_IN, label='CO2_YEAR:', DEFAULT= -9999, __RC__ ) @@ -5170,24 +5163,9 @@ subroutine Driver ( RC ) real, allocatable, dimension(:) :: ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp real, allocatable, dimension(:) :: SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp - ! Variables for FPAR scaling - ! -------------------------- - - real, save,allocatable,dimension (:,:,:,:) :: Kappa, Lambda, Mu - real, save,allocatable,dimension (:,:,:) :: MnVal, MxVal - integer, save, allocatable, dimension (:) :: modis_tid, ThisMIndex - integer :: n_modis, NTCurrent, CDFfile, infos, comms - integer, allocatable, dimension (:,:) :: modis_index - integer, allocatable, dimension (:) :: modis2cat - real , allocatable, dimension (:) :: m_lons, m_lats - real , allocatable, dimension (:,:) :: scaled_fpar, parav, parzone, unscaled_fpar - REAL , PARAMETER :: TILEINT = 2. - integer, PARAMETER :: NOCTAD = 46, NSETS = 2 - real :: CLM4_fpar, CLM4_cdf, MODIS_fpar, tmparr(1,1,1,2), & - ThisK, ThisL, ThisM, ThisMin, ThisMax, tmparr2(1,1,1), ThisFPAR, ZFPAR - character (len=ESMF_MAXSTR) :: VISMEANFILE, VISSTDFILE, NIRMEANFILE, NIRSTDFILE, FPARMEANFILE, FPARSTDFILE - real, allocatable, dimension (:) :: MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd - logical, save :: first_fpar = .true. + ! Variables for FPAR + ! -------------------------- + real , allocatable, dimension (:,:) :: parzone IAm=trim(COMP_NAME)//"::RUN2::Driver" @@ -5702,123 +5680,6 @@ subroutine Driver ( RC ) ENDIF READ_CT_CO2 ENDIF - ! OPTIONAL FPAR SCALING -! --------------------- - - if (SCALE_ALBFPAR >= 2) then - IF (ntiles > 0) THEN - INTILALIZE_FPAR_PARAM : if(first_fpar) then - - ! Initialize FPAR MODIS scale parameters - ! -------------------------------------- - -! CALL ESMF_VMGet(vm, MPICOMMUNICATOR=comms, rc=status) -! VERIFY_(status) -! call MPI_Info_create(infos, STATUS) -! call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) - - STATUS = NF_OPEN ('FPAR_CDF_Params-M09.nc4', NF_NOWRITE, CDFfile) - STATUS = NF_INQ_DIMID (CDFfile, 'tile10D', k); VERIFY_(STATUS) - STATUS = NF_INQ_DIMLEN (CDFfile, K, n_modis) ; VERIFY_(STATUS) - - allocate (m_lons (1 : n_modis)) - allocate (m_lats (1 : n_modis)) - - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lon'), (/1/), (/n_modis/), m_lons);VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lat'), (/1/), (/n_modis/), m_lats);VERIFY_(STATUS) - - allocate (modis_index (1: 360/nint(TILEINT), 1: 180/nint(TILEINT))) - modis_index = -9999 - - ! vector to grid 10x10 MODIS tiles - - do i = 1, n_modis - - k = NINT (((m_lons(i) + TILEINT/2.) + 180.) / TILEINT) - n = NINT (((m_lats(i) + TILEINT/2.) + 90.) / TILEINT) - modis_index (k, n) = i - - end do - - ! for each catchment-tile overlying MODIS 10x10 tile - - allocate (modis2cat (1: NTILES)) - allocate (modis_tid (1: NTILES)) - - modis_tid = -9999 - modis2cat = 0 - - do i = 1, NTILES - - k = NINT ((CEILING (lons(i)*90./MAPL_PI)*2 + 180.) / TILEINT) - n = NINT ((CEILING (lats(i)*90./MAPL_PI)*2 + 90.) / TILEINT) - if(k <= 3) k = 3 - if(k >= 178) k = 178 - modis2cat (i) = modis_index (k,n) - - end do - - K = count(modis2cat > 0) - - allocate (unq_mask(1:K )) - allocate (loc_int (1:K )) - - loc_int = pack(modis2cat ,mask = (modis2cat > 0)) - call MAPL_Sort (loc_int) - unq_mask = .true. - - do i = 2,K - unq_mask(i) = .not.(loc_int(i) == loc_int(i-1)) - end do - - NUNQ = count(unq_mask) - - allocate (ThisIndex (1:NUNQ)) - ThisIndex = pack(loc_int, mask = unq_mask ) - - allocate (Kappa (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Lambda(1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Mu (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (MnVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - allocate (MxVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - - Kappa = -9999. - Lambda = -9999. - Mu = -9999. - - do i = 1, NUNQ - - where (modis2cat == ThisIndex(i)) modis_tid = i - - end do - - do i = 1, NUNQ - do K = 1,NOCTAD - do n = 1, NUMPFT - IF (ThisIndex(i) >= 1) THEN - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Kappa' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Kappa (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Lambda'),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Lambda(i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Mu' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Mu (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MinVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MnVal(i,N,K) = tmparr2 (1,1,1) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MaxVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MxVal(i,N,K) = tmparr2 (1,1,1) - ENDIF - end do - end do - end do - status = NF_CLOSE (CDFFile) - - deallocate ( modis2cat, unq_mask, loc_int, modis_index, m_lons, m_lats) - - first_fpar = .false. - - endif INTILALIZE_FPAR_PARAM - endif - end if ! -------------------------------------------------------------------------- ! ALLOCATE LOCAL POINTERS @@ -6352,11 +6213,7 @@ subroutine Driver ( RC ) allocate( car1(ntiles) ) allocate( car2(ntiles) ) allocate( car4(ntiles) ) - allocate( parzone(ntiles,nveg) ) allocate( para(ntiles) ) - allocate( parav(ntiles,nveg) ) - allocate (scaled_fpar (NTILES,NVEG)) - allocate (unscaled_fpar(NTILES,NVEG)) allocate ( totwat(ntiles) ) if(.not. allocated(npp )) allocate( npp(ntiles) ) if(.not. allocated(gpp )) allocate( gpp(ntiles) ) @@ -6382,6 +6239,7 @@ subroutine Driver ( RC ) allocate( psnsunx(ntiles,nveg) ) allocate( psnshax(ntiles,nveg) ) + allocate( parzone(ntiles,nveg) ) allocate( sifsunx(ntiles,nveg) ) allocate( sifshax(ntiles,nveg) ) allocate( laisunx(ntiles,nveg) ) @@ -6657,8 +6515,6 @@ subroutine Driver ( RC ) end do para(:) = 0. ! zero out absorbed PAR summing array - parav(:, :) = 0. ! - scaled_fpar = 1. do nz = 1,nzone @@ -6754,8 +6610,8 @@ subroutine Driver ( RC ) do nv = 1,nveg para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) end do + if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) if(associated(SIF)) then do nv = 1,nveg @@ -6765,157 +6621,6 @@ subroutine Driver ( RC ) end do - do nv = 1,nveg - unscaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do - - NTCurrent = CEILING (real (dofyr) / 8.) - - ! FPAR scaling to match MODIS CDF - ! ------------------------------- - - DO_FS1 : if (SCALE_ALBFPAR >= 2) then - - IF (ntiles > 0) THEN - - NT_LOOP1 : do n = 1,NTILES - - NV_LOOP1 : do nv = 1,nveg - - CLM4_fpar = parav (n,nv) / (DRPAR (n) + DFPAR (n) + 1.e-20) - K = -1 - - if(CLM4_fpar > 0.) then - - k = NINT(ITY(N,nv)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) then - k = -1 - if(nv == 1) k = NINT(ITY(N,2)) - if(nv == 2) k = NINT(ITY(N,1)) - if(nv == 3) k = NINT(ITY(N,4)) - if(nv == 4) k = NINT(ITY(N,3)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) k = -1 - if((K == -1).and.(nv > 2)) then - if(minval(Kappa (modis_tid (n), NINT(ITY(N,2)), NTCurrent, :)) > 0.) k = NINT(ITY(N,2)) - if(minval(Kappa (modis_tid (n), NINT(ITY(N,1)), NTCurrent, :)) > 0.) k = NINT(ITY(N,1)) - endif - endif - - endif - - if((K > 0).and.(CLM4_fpar > 0)) then - - ! Computing probability of CLM4 FPAR - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 2) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 2) - ThisM = Mu (modis_tid (n), k, NTCurrent, 2) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - if (CLM4_fpar < ThisMin) CLM4_fpar = ThisMin - if (CLM4_fpar > ThisMax) CLM4_fpar = ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,thisK,ThisL, ThisM, CLM4_fpar, ThisMin, ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,n,k,NTCurrent,modis_tid (n) - CLM4_cdf = ThisK * betai (ThisL, ThisM, (CLM4_fpar - ThisMin)/ThisMax) - - ! Computing corresponding MODIS FPAR for the same probability - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 1) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 1) - ThisM = Mu (modis_tid (n), k, NTCurrent, 1) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - scaled_fpar (n,nv) = cdf2fpar (CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax) - if((scaled_fpar (n,nv) > 1.).or.(scaled_fpar (n,nv) < 0.)) then - print *, 'PROB 1', CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax, scaled_fpar (n,nv) - endif - - scaled_fpar (n,nv) = scaled_fpar (n,nv) / (CLM4_fpar + 1.e-20) - - endif - end do NV_LOOP1 - - end do NT_LOOP1 - - para (:) = 0. ! zero out absorbed PAR summing array - parav = 0. - - if(associated(BTRANT)) btrant = 0. - if(associated(SIF)) sif = 0. - - do nz = 1,num_zon - - if(nz == 1) then - btran = btran1 - tcx = tx1 - qax = qx1 - endif - - if(nz == 2) then - btran = btran2 - tcx = tx2 - qax = qx2 - endif - - if(nz == 3) then - btran = btran3 - tcx = tx3 - qax = qx3 - endif - - do nv = 1,num_veg - elaz(:,nv) = elai(:,nv,nz) - esaz(:,nv) = esai(:,nv,nz) - ityz(:,nv) = ityp(:,nv,nz) - fvez(:,nv) = fveg(:,nv,nz) - end do - - do n = 1,NTILES - if(tp1(n) < (Tzero-0.01)) btran(n) = 0. ! no photosynthesis if ground fully frozen - end do - - call compute_rc(NTILES,nveg,TCx,QAx, & - TA, PS, ZTH,DRPAR,DFPAR, & - elaz,esaz,ityz,fvez,btran,fwet, & - RCx,RCxDT,RCxDQ,psnsunx,psnshax,laisunx,laishax, & - dayl_fac,co2v,dtc,dea,parzone,sifsunx,sifshax, & - fpar_sf = scaled_fpar ) - - rc00(:,nz) = rcx(:) - rcdt(:,nz) = rcxdt(:) - rcdq(:,nz) = rcxdq(:) - - psnsun(:,:,nz) = psnsunx(:,:) - psnsha(:,:,nz) = psnshax(:,:) - laisun(:,:,nz) = laisunx(:,:) - laisha(:,:,nz) = laishax(:,:) - - do nv = 1,nveg - para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) - end do - - if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) - if(associated(SIF)) then - do nv = 1,nveg - sif(:) = sif(:) + wtzone(:,nz)*fvez(:,nv)*(sifsunx(:,nv)*laisunx(:,nv) + sifshax(:,nv)*laishax(:,nv)) - end do - endif - - end do - - endif - - endif DO_FS1 - - ! Below we are recycling the scaled_fpar array - from this point, it contains fpar scaled or otherwise - ! ---------------------------------------------------------------------------------------------------- - - do nv = 1,nveg - scaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do if(associated(CNCO2)) CNCO2 = CO2V * 1e6 deallocate (co2v) @@ -6940,40 +6645,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - - if(.not.allocated (MODISVISmean )) allocate (MODISVISmean (1:NTILES)) - if(.not.allocated (MODISVISstd )) allocate (MODISVISstd (1:NTILES)) - if(.not.allocated (MODISNIRmean )) allocate (MODISNIRmean (1:NTILES)) - if(.not.allocated (MODISNIRstd )) allocate (MODISNIRstd (1:NTILES)) - if(.not.allocated (MODELFPARmean)) allocate (MODELFPARmean (1:NTILES)) - if(.not.allocated (MODELFPARstd )) allocate (MODELFPARstd (1:NTILES)) - - if(ntiles > 0) then - - call MAPL_GetResource(MAPL,VISMEANFILE , label = 'VISMEAN_FILE:' , default = 'MODISVISmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,VISSTDFILE , label = 'VISSTD_FILE:' , default = 'MODISVISstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRMEANFILE , label = 'NIRMEAN_FILE:' , default = 'MODISNIRmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRSTDFILE , label = 'NIRSTD_FILE:' , default = 'MODISNIRstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_GetResource(MAPL,FPARMEANFILE , label = 'MODELFPARMEAN_FILE:', default = 'MODELFPARmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,FPARSTDFILE , label = 'MODELFPARSTD_FILE:' , default = 'MODELFPARstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_ReadForcing(MAPL,'MODISVISmean' ,VISMEANFILE ,CURRENT_TIME,MODISVISmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISVISstd' ,VISSTDFILE ,CURRENT_TIME,MODISVISstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRmean' ,NIRMEANFILE ,CURRENT_TIME,MODISNIRmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRstd' ,NIRSTDFILE ,CURRENT_TIME,MODISNIRstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARmean',FPARMEANFILE,CURRENT_TIME,MODELFPARmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARstd' ,FPARSTDFILE ,CURRENT_TIME,MODELFPARstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -6990,16 +6661,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - if(ntiles > 0) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -7643,13 +7304,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - end do - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -7666,17 +7320,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - if(ntiles > 0) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - if(allocated (MODISVISmean)) deallocate (MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd) - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -8023,11 +7666,7 @@ subroutine Driver ( RC ) deallocate( car1 ) deallocate( car2 ) deallocate( car4 ) - deallocate( parzone ) deallocate( para ) - deallocate( parav ) - deallocate(scaled_fpar) - deallocate(UNscaled_fpar) deallocate( totwat ) deallocate( dayl ) deallocate(dayl_fac ) @@ -8042,6 +7681,7 @@ subroutine Driver ( RC ) deallocate( psnsunx ) deallocate( psnshax ) deallocate( sifsunx ) + deallocate( parzone ) deallocate( sifshax ) deallocate( laisunx ) deallocate( laishax ) @@ -8070,32 +7710,6 @@ subroutine Driver ( RC ) end subroutine Driver - ! ----------------- routines for CDF scaling ------------------- - - REAL FUNCTION cdf2fpar (cdf, k,l, m, m1, m2) - - REAL, intent (in) :: cdf, k,l,m, m1, m2 - REAL :: x, ThisCDF, ThisFPAR - integer, parameter :: nBINS = 40 - - x = real (nBINS) - ThisCDF = 1. - - do while (ThisCDF >= cdf) - ThisFPAR = 1. - (real(nbins)-x)/real(nbins) - 1./2./real(nbins) - ThisCDF = K * betai (L, M, ThisFPAR) - x = x - 1. - if(x == 0) exit - end do - - cdf2fpar = ThisFPAR * m2 + m1 - if(cdf2fpar > m2) cdf2fpar = m2 - if(cdf2fpar < m1) cdf2fpar = m1 - return - - END FUNCTION cdf2fpar - - ! --------------------------------------------------------- FUNCTION betai(a,b,x) REAL betai,a,b,x diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index 5caaa0425..e5b6680e5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -174,7 +174,7 @@ module GEOS_CatchCNCLM45GridCompMod end type OFFLINE_WRAP integer :: RUN_IRRIG, USE_ASCATZ0, Z0_FORMULATION, IRRIG_METHOD, AEROSOL_DEPOSITION, N_CONST_LAND4SNWALB -integer :: ATM_CO2, SCALE_ALBFPAR,CHOOSEMOSFC +integer :: ATM_CO2, CHOOSEMOSFC real :: SURFLAY ! Default (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params real :: CO2 @@ -291,12 +291,6 @@ subroutine SetServices ( GC, RC ) ! 4: import AGCM model CO2 (AGCM only) call MAPL_GetResource (SCF, ATM_CO2, label='ATM_CO2:', DEFAULT=2 , __RC__ ) - ! SCALE_ALBFPAR: Scale CATCHCN ALBEDO and FPAR - ! 0-- NO scaling is performed - ! 1-- Scale albedo to match interannually varying MODIS NIRDF and VISDF anomaly - ! 2-- Scale albedo to match CDFs of model fPAR to MODIS CDFs of fPAR - ! 3-- Pefform above both 1 and 2 scalings - call MAPL_GetResource (SCF, SCALE_ALBFPAR, label='SCALE_ALBFPAR:', DEFAULT=0 , __RC__ ) ! Global mean CO2 call MAPL_GetResource (SCF, CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) @@ -4453,7 +4447,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp),pointer :: MAPL type(ESMF_Alarm) :: ALARM - integer :: IM,JM integer :: incl_Louis_extra_derivs @@ -5155,24 +5148,9 @@ subroutine Driver ( RC ) real, allocatable, dimension(:) :: ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp real, allocatable, dimension(:) :: SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp - ! Variables for FPAR scaling - ! -------------------------- - - real, save,allocatable,dimension (:,:,:,:) :: Kappa, Lambda, Mu - real, save,allocatable,dimension (:,:,:) :: MnVal, MxVal - integer, save, allocatable, dimension (:) :: modis_tid, ThisMIndex - integer :: n_modis, NTCurrent, CDFfile, infos, comms - integer, allocatable, dimension (:,:) :: modis_index - integer, allocatable, dimension (:) :: modis2cat - real , allocatable, dimension (:) :: m_lons, m_lats - real , allocatable, dimension (:,:) :: scaled_fpar, parav, parzone, unscaled_fpar - REAL , PARAMETER :: TILEINT = 2. - integer, PARAMETER :: NOCTAD = 46, NSETS = 2 - real :: CLM4_fpar, CLM4_cdf, MODIS_fpar, tmparr(1,1,1,2), & - ThisK, ThisL, ThisM, ThisMin, ThisMax, tmparr2(1,1,1), ThisFPAR, ZFPAR - character (len=ESMF_MAXSTR) :: VISMEANFILE, VISSTDFILE, NIRMEANFILE, NIRSTDFILE, FPARMEANFILE, FPARSTDFILE - real, allocatable, dimension (:) :: MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd - logical, save :: first_fpar = .true. + ! Variables for FPAR + ! -------------------------- + real , allocatable, dimension (:,:) :: parzone IAm=trim(COMP_NAME)//"::RUN2::Driver" @@ -5699,123 +5677,6 @@ subroutine Driver ( RC ) ENDIF READ_CT_CO2 ENDIF - ! OPTIONAL FPAR SCALING -! --------------------- - - if (SCALE_ALBFPAR >= 2) then - IF (ntiles > 0) THEN - INTILALIZE_FPAR_PARAM : if(first_fpar) then - - ! Initialize FPAR MODIS scale parameters - ! -------------------------------------- - -! CALL ESMF_VMGet(vm, MPICOMMUNICATOR=comms, rc=status) -! VERIFY_(status) -! call MPI_Info_create(infos, STATUS) -! call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) - - STATUS = NF_OPEN ('FPAR_CDF_Params-M09.nc4', NF_NOWRITE, CDFfile) - STATUS = NF_INQ_DIMID (CDFfile, 'tile10D', k); VERIFY_(STATUS) - STATUS = NF_INQ_DIMLEN (CDFfile, K, n_modis) ; VERIFY_(STATUS) - - allocate (m_lons (1 : n_modis)) - allocate (m_lats (1 : n_modis)) - - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lon'), (/1/), (/n_modis/), m_lons);VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lat'), (/1/), (/n_modis/), m_lats);VERIFY_(STATUS) - - allocate (modis_index (1: 360/nint(TILEINT), 1: 180/nint(TILEINT))) - modis_index = -9999 - - ! vector to grid 10x10 MODIS tiles - - do i = 1, n_modis - - k = NINT (((m_lons(i) + TILEINT/2.) + 180.) / TILEINT) - n = NINT (((m_lats(i) + TILEINT/2.) + 90.) / TILEINT) - modis_index (k, n) = i - - end do - - ! for each catchment-tile overlying MODIS 10x10 tile - - allocate (modis2cat (1: NTILES)) - allocate (modis_tid (1: NTILES)) - - modis_tid = -9999 - modis2cat = 0 - - do i = 1, NTILES - - k = NINT ((CEILING (lons(i)*90./MAPL_PI)*2 + 180.) / TILEINT) - n = NINT ((CEILING (lats(i)*90./MAPL_PI)*2 + 90.) / TILEINT) - if(k <= 3) k = 3 - if(k >= 178) k = 178 - modis2cat (i) = modis_index (k,n) - - end do - - K = count(modis2cat > 0) - - allocate (unq_mask(1:K )) - allocate (loc_int (1:K )) - - loc_int = pack(modis2cat ,mask = (modis2cat > 0)) - call MAPL_Sort (loc_int) - unq_mask = .true. - - do i = 2,K - unq_mask(i) = .not.(loc_int(i) == loc_int(i-1)) - end do - - NUNQ = count(unq_mask) - - allocate (ThisIndex (1:NUNQ)) - ThisIndex = pack(loc_int, mask = unq_mask ) - - allocate (Kappa (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Lambda(1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Mu (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (MnVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - allocate (MxVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - - Kappa = -9999. - Lambda = -9999. - Mu = -9999. - - do i = 1, NUNQ - - where (modis2cat == ThisIndex(i)) modis_tid = i - - end do - - do i = 1, NUNQ - do K = 1,NOCTAD - do n = 1, NUMPFT - IF (ThisIndex(i) >= 1) THEN - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Kappa' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Kappa (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Lambda'),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Lambda(i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Mu' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Mu (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MinVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MnVal(i,N,K) = tmparr2 (1,1,1) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MaxVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MxVal(i,N,K) = tmparr2 (1,1,1) - ENDIF - end do - end do - end do - status = NF_CLOSE (CDFFile) - - deallocate ( modis2cat, unq_mask, loc_int, modis_index, m_lons, m_lats) - - first_fpar = .false. - - endif INTILALIZE_FPAR_PARAM - endif - end if ! -------------------------------------------------------------------------- ! ALLOCATE LOCAL POINTERS @@ -6354,11 +6215,7 @@ subroutine Driver ( RC ) allocate( car1(ntiles) ) allocate( car2(ntiles) ) allocate( car4(ntiles) ) - allocate( parzone(ntiles,nveg) ) allocate( para(ntiles) ) - allocate( parav(ntiles,nveg) ) - allocate (scaled_fpar (NTILES,NVEG)) - allocate (unscaled_fpar(NTILES,NVEG)) allocate ( totwat(ntiles) ) if(.not. allocated(npp )) allocate( npp(ntiles) ) if(.not. allocated(gpp )) allocate( gpp(ntiles) ) @@ -6427,6 +6284,7 @@ subroutine Driver ( RC ) allocate( psnsunx(ntiles,nveg) ) allocate( psnshax(ntiles,nveg) ) allocate( sifsunx(ntiles,nveg) ) + allocate( parzone(ntiles,nveg) ) allocate( sifshax(ntiles,nveg) ) allocate( laisunx(ntiles,nveg) ) allocate( laishax(ntiles,nveg) ) @@ -6767,8 +6625,6 @@ subroutine Driver ( RC ) end do para(:) = 0. ! zero out absorbed PAR summing array - parav(:, :) = 0. ! - scaled_fpar = 1. do nz = 1,nzone @@ -6904,8 +6760,8 @@ subroutine Driver ( RC ) do nv = 1,nveg para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) end do + if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) ! NOTE: btran here doesn't reflect the modification to btran for soybean (and nbrdlf_dcd_tmp_shrub if CNDV is on) in subroutine Photosynthesis. if(associated(SIF)) then do nv = 1,nveg @@ -6915,159 +6771,6 @@ subroutine Driver ( RC ) end do - do nv = 1,nveg - unscaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do - - NTCurrent = CEILING (real (dofyr) / 8.) - - ! FPAR scaling to match MODIS CDF - ! ------------------------------- - - DO_FS1 : if (SCALE_ALBFPAR >= 2) then - - IF (ntiles > 0) THEN - - NT_LOOP1 : do n = 1,NTILES - - NV_LOOP1 : do nv = 1,nveg - - CLM4_fpar = parav (n,nv) / (DRPAR (n) + DFPAR (n) + 1.e-20) - K = -1 - - if(CLM4_fpar > 0.) then - - k = NINT(ITY(N,nv)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) then - k = -1 - if(nv == 1) k = NINT(ITY(N,2)) - if(nv == 2) k = NINT(ITY(N,1)) - if(nv == 3) k = NINT(ITY(N,4)) - if(nv == 4) k = NINT(ITY(N,3)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) k = -1 - if((K == -1).and.(nv > 2)) then - if(minval(Kappa (modis_tid (n), NINT(ITY(N,2)), NTCurrent, :)) > 0.) k = NINT(ITY(N,2)) - if(minval(Kappa (modis_tid (n), NINT(ITY(N,1)), NTCurrent, :)) > 0.) k = NINT(ITY(N,1)) - endif - endif - - endif - - if((K > 0).and.(CLM4_fpar > 0)) then - - ! Computing probability of CLM4 FPAR - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 2) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 2) - ThisM = Mu (modis_tid (n), k, NTCurrent, 2) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - if (CLM4_fpar < ThisMin) CLM4_fpar = ThisMin - if (CLM4_fpar > ThisMax) CLM4_fpar = ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,thisK,ThisL, ThisM, CLM4_fpar, ThisMin, ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,n,k,NTCurrent,modis_tid (n) - CLM4_cdf = ThisK * betai (ThisL, ThisM, (CLM4_fpar - ThisMin)/ThisMax) - - ! Computing corresponding MODIS FPAR for the same probability - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 1) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 1) - ThisM = Mu (modis_tid (n), k, NTCurrent, 1) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - scaled_fpar (n,nv) = cdf2fpar (CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax) - if((scaled_fpar (n,nv) > 1.).or.(scaled_fpar (n,nv) < 0.)) then - print *, 'PROB 1', CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax, scaled_fpar (n,nv) - endif - - scaled_fpar (n,nv) = scaled_fpar (n,nv) / (CLM4_fpar + 1.e-20) - - endif - end do NV_LOOP1 - - end do NT_LOOP1 - - para (:) = 0. ! zero out absorbed PAR summing array - parav = 0. - - if(associated(BTRANT)) btrant = 0. - if(associated(SIF)) sif = 0. - - do nz = 1,num_zon - - if(nz == 1) then - btran = btran1 - tcx = tx1 - qax = qx1 - endif - - if(nz == 2) then - btran = btran2 - tcx = tx2 - qax = qx2 - endif - - if(nz == 3) then - btran = btran3 - tcx = tx3 - qax = qx3 - endif - - do nv = 1,num_veg - elaz(:,nv) = elai(:,nv,nz) - esaz(:,nv) = esai(:,nv,nz) - ityz(:,nv) = ityp(:,nv,nz) - fvez(:,nv) = fveg(:,nv,nz) - end do - - do n = 1,NTILES - if(tp1(n) < (Tzero-0.01)) btran(n) = 0. ! no photosynthesis if ground fully frozen - end do - - call compute_rc(NTILES,nveg,TCx,QAx,T2M10D, & - TA, PS, ZTH,DRPAR,DFPAR,albdir,albdif, & - elaz,esaz,ityz,fvez,btran,fwet, & - RCx,RCxDT,RCxDQ,psnsunx,psnshax,laisunx,laishax, & - dayl_fac,co2v,dtc,dea,parzone,sifsunx,sifshax, & - lmrsunx,lmrshax,fpar_sf = scaled_fpar ) - - rc00(:,nz) = rcx(:) - rcdt(:,nz) = rcxdt(:) - rcdq(:,nz) = rcxdq(:) - - psnsun(:,:,nz) = psnsunx(:,:) - psnsha(:,:,nz) = psnshax(:,:) - laisun(:,:,nz) = laisunx(:,:) - laisha(:,:,nz) = laishax(:,:) - lmrsun(:,:,nz) = lmrsunx(:,:) - lmrsha(:,:,nz) = lmrshax(:,:) - - do nv = 1,nveg - para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) - end do - - if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) - if(associated(SIF)) then - do nv = 1,nveg - sif(:) = sif(:) + wtzone(:,nz)*fvez(:,nv)*(sifsunx(:,nv)*laisunx(:,nv) + sifshax(:,nv)*laishax(:,nv)) - end do - endif - - end do - - endif - - endif DO_FS1 - - ! Below we are recycling the scaled_fpar array - from this point, it contains fpar scaled or otherwise - ! ---------------------------------------------------------------------------------------------------- - - do nv = 1,nveg - scaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do if(associated(CNCO2)) CNCO2 = CO2V * 1e6 deallocate (co2v) @@ -7092,40 +6795,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - - if(.not.allocated (MODISVISmean )) allocate (MODISVISmean (1:NTILES)) - if(.not.allocated (MODISVISstd )) allocate (MODISVISstd (1:NTILES)) - if(.not.allocated (MODISNIRmean )) allocate (MODISNIRmean (1:NTILES)) - if(.not.allocated (MODISNIRstd )) allocate (MODISNIRstd (1:NTILES)) - if(.not.allocated (MODELFPARmean)) allocate (MODELFPARmean (1:NTILES)) - if(.not.allocated (MODELFPARstd )) allocate (MODELFPARstd (1:NTILES)) - - if(ntiles > 0) then - - call MAPL_GetResource(MAPL,VISMEANFILE , label = 'VISMEAN_FILE:' , default = 'MODISVISmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,VISSTDFILE , label = 'VISSTD_FILE:' , default = 'MODISVISstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRMEANFILE , label = 'NIRMEAN_FILE:' , default = 'MODISNIRmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRSTDFILE , label = 'NIRSTD_FILE:' , default = 'MODISNIRstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_GetResource(MAPL,FPARMEANFILE , label = 'MODELFPARMEAN_FILE:', default = 'MODELFPARmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,FPARSTDFILE , label = 'MODELFPARSTD_FILE:' , default = 'MODELFPARstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_ReadForcing(MAPL,'MODISVISmean' ,VISMEANFILE ,CURRENT_TIME,MODISVISmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISVISstd' ,VISSTDFILE ,CURRENT_TIME,MODISVISstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRmean' ,NIRMEANFILE ,CURRENT_TIME,MODISNIRmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRstd' ,NIRSTDFILE ,CURRENT_TIME,MODISNIRstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARmean',FPARMEANFILE,CURRENT_TIME,MODELFPARmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARstd' ,FPARSTDFILE ,CURRENT_TIME,MODELFPARstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -7142,16 +6811,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - if(ntiles > 0) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -7896,13 +7555,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - end do - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -7919,17 +7571,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - - if(allocated (MODISVISmean)) deallocate (MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd) - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -8281,11 +7922,7 @@ subroutine Driver ( RC ) deallocate( car1 ) deallocate( car2 ) deallocate( car4 ) - deallocate( parzone ) deallocate( para ) - deallocate( parav ) - deallocate (scaled_fpar) - deallocate (UNscaled_fpar) deallocate( totwat ) deallocate( nfire ) deallocate(som_closs) @@ -8342,6 +7979,7 @@ subroutine Driver ( RC ) deallocate( psnsunx ) deallocate( psnshax ) deallocate( sifsunx ) + deallocate( parzone ) deallocate( sifshax ) deallocate( laisunx ) deallocate( laishax ) @@ -8374,32 +8012,6 @@ subroutine Driver ( RC ) end subroutine Driver - ! ----------------- routines for CDF scaling ------------------- - - REAL FUNCTION cdf2fpar (cdf, k,l, m, m1, m2) - - REAL, intent (in) :: cdf, k,l,m, m1, m2 - REAL :: x, ThisCDF, ThisFPAR - integer, parameter :: nBINS = 40 - - x = real (nBINS) - ThisCDF = 1. - - do while (ThisCDF >= cdf) - ThisFPAR = 1. - (real(nbins)-x)/real(nbins) - 1./2./real(nbins) - ThisCDF = K * betai (L, M, ThisFPAR) - x = x - 1. - if(x == 0) exit - end do - - cdf2fpar = ThisFPAR * m2 + m1 - if(cdf2fpar > m2) cdf2fpar = m2 - if(cdf2fpar < m1) cdf2fpar = m1 - return - - END FUNCTION cdf2fpar - - ! --------------------------------------------------------- FUNCTION betai(a,b,x) REAL betai,a,b,x diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 deleted file mode 100755 index 2e1314a3d..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 +++ /dev/null @@ -1,801 +0,0 @@ -#include "Raster.h" - -PROGRAM comp_FPAR_CDF - - use math_routines - use MAPL_SortMod - use date_time_util, ONLY: & - date_time_type, augment_date_time - use ieee_arithmetic, only: isnan => ieee_is_nan - IMPLICIT NONE - - INCLUDE 'netcdf.inc' - INCLUDE 'mpif.h' - - integer :: comm_rank, comm_size, error, info, DOY,NCInID,NCOutID, NCOutID2, n, iargc, STATUS - integer :: stat(MPI_STATUS_SIZE), NTILES, NCatch, NDATA1, NDATA2,N_VIS_DATA, N_NIR_DATA - character*400 :: arg(2) - REAL, PARAMETER :: TILESIZE = 10., TILEINT = 2. - INTEGER, PARAMETER :: NPFT = 19, NOCTAD = 46, NSETS = 2 ,MXCNT = 500000 - logical, parameter :: onebin = .true. - INTEGER, PARAMETER :: YearB = 2003, YearE = 2016 - character*400, PARAMETER :: & - BCSDIR = 'SMAP_EASEv2_M09/', & - EXPDIR = '/discover/nobackup/fzeng/Catchment/SMAP_EASEv2_M09/e0004s_wet2/output/SMAP_EASEv2_M09_GLOBAL/', & - EXNAME = 'e0004s_wet2', & - OUTFIL = 'global_alb_mu_std/FPAR_CDF_Params-M09', & - LOGFIL = 'global_alb_mu_std/FPAR_CDF_Params-M09_log.', & - GFILE = 'SMAP_EASEv2_M09_3856x1624' - - logical :: file_exists, put_aux = .true. -! real, dimension (4) :: limits = (/20., -130., 60., -60./) - real, dimension (4) :: limits = (/-90., -180., 90., 180./) - real, dimension (NBINS) :: MODIS_BINS, CLM4_BINS - INTEGER :: I_INDEX(10),JM, IM, NC, NT, year, day, maxcat, ThisTile, req - type(date_time_type), dimension (YearE - YearB + 1) :: octad_time - CHARACTER*8 :: YYYYMMDD - CHARACTER*6 :: YYYYMM - CHARACTER*4 :: YYYY - CHARACTER*2 :: MM, DD,MMR, TSLICE - INTEGER :: i, j,k, pf, i1,i2,i3,i4, f1,f2,f3,f4, ND - INTEGER, DIMENSION (:,:), allocatable :: veg_index, catchs_all - integer, allocatable, dimension (:) :: ldas2bcs, Catchs, NCATCH_ALL - real :: yr,mn,dy,dum,yr1,mn1,dy1, lw, up, db, mean, std, skew, & - minv, maxv, minv1, maxv1, minv2, maxv2, VISmean, FPARmean, FPARstd, NIRmean, NIRstd, VISstd, r2, var1, var2 - real, dimension (:,:), allocatable :: modis_fpar, clm4_fpar, modis_visdf, modis_nirdf - real, dimension (:), allocatable :: modis_cdf, clm4_cdf, data_read, data_save, modis_hist, clm4_hist - real, dimension (:), allocatable :: vis_this, nir_this, fpar_this, est_this - real (kind=8), dimension(NBINS) :: dbins,dcdf - real (kind=8), dimension(3) :: modis_param, clm4_param - real , dimension(NBINS*2 + 13 + 6) :: tmp_real - character*300 :: tmpstring - - call MPI_Init(error) - call MPI_COMM_Size(MPI_COMM_WORLD,comm_size,error) - call MPI_COMM_Rank(MPI_COMM_WORLD,comm_rank,error) - - call MPI_Info_create(info, error) - call MPI_Info_set(info, "romio_cb_read", "automatic", error) - - write (TSLICE ,'(i2.2)') comm_rank + 1 - open (99,file=trim(logfil)//TSLICE, form ='formatted', action='write', status= 'unknown') - - ! STEP 1 check/create CDF params files - - inquire(file=trim(OUTFIL)//'.nc4', exist = file_exists) - - if(.not.file_exists) then - if(comm_rank == 0) then - call create_CDF_ParamFile - WRITE (99,*)'CREATED CDF PARAM FILE : ', trim(OUTFIL)//'.nc4' - endif - endif - - call MPI_BARRIER( MPI_COMM_WORLD, error) - - ! READ # OF 10x10 MODIS TILES AND SMAP_TILE_IDs THAT CONTRIBUTE TO EACH MODIS TILE - - STATUS = NF_OPEN (trim(OUTFIL)//'_aux.nc4', NF_NOWRITE,NCInID) ; VERIFY_(STATUS) - STATUS = NF_INQ_DIMID (NCInID, 'tile10D', K); VERIFY_(STATUS) - CALL HANDLE_ERR(STATUS, 'INQ_DIM') - STATUS = NF_INQ_DIMLEN (NCInID, K, NTILES); VERIFY_(STATUS) - CALL HANDLE_ERR(STATUS, 'DIMLEN_NTILES') - WRITE (99,*)'NOF 10D CELLS : ', NTILES - - allocate (NCatch_all (1:NTILES)) - allocate (Catchs_all (1:16000,1:NTILES)) - - STATUS = NF_GET_VARA_INT (NCInID, VarID(NCInID,'nSMAP'), (/1/), (/NTILES/), NCatch_ALL); VERIFY_(STATUS) - STATUS = NF_GET_VARA_INT (NCInID, VarID(NCInID,'SMAPID'), (/1, 1/), (/16000,NTILES/), Catchs_ALL); VERIFY_(STATUS) - status = NF_CLOSE (NCInID) - - call MPI_BARRIER( MPI_COMM_WORLD, error) - - if(comm_rank == 0) then - - ! ROOT PROCESSOR OPENS FILES TO UPDATE CDF PARAMS - - STATUS = NF_OPEN (trim(OUTFIL)//'.nc4' ,NF_WRITE,NCOutID ) - VERIFY_(STATUS) - STATUS = NF_OPEN (trim(OUTFIL)//'_aux.nc4',NF_WRITE,NCOutID2) - VERIFY_(STATUS) - - endif - - ! read maxcat, LDASsa tile order, veg types and define binvals - - open (10,file=trim(BCSDIR)//'clsm/catchment.def', status='old',action='read', & - form='formatted') - - read (10,*) maxcat - - close (10, status ='keep') - - allocate (veg_index (1: NPFT, 1: MAXCAT)) - allocate (ldas2bcs (1: maxcat)) - allocate (data_read (1: maxcat)) - allocate (data_save (1: maxcat)) - allocate (modis_fpar (1: maxcat, yearE - yearB + 1)) - allocate (clm4_fpar (1: maxcat, yearE - yearB + 1)) - allocate (modis_visdf (1: maxcat, yearE - yearB)) - allocate (modis_nirdf (1: maxcat, yearE - yearB)) - - clm4_fpar = 0. - modis_fpar = 0. - data_save = 0. - veg_index = -9999 - - open (10,file =trim(EXPDIR)//'rc_out/'//trim(EXNAME)//'.ldas_tilecoord.bin',status='old',form='unformatted',convert='big_endian') - read (10) i - read (10) LDAS2BCS - close (10, status = 'keep') - - open (10,file=trim(BCSDIR)//'clsm/CLM_veg_typs_fracs', status='old',action='read', & - form='formatted') - - do i = 1, maxcat - - read (10,*) pf, pf, i1,i2,i3,i4, f1,f2,f3,f4 - - if(f1 >= f2) then - veg_index (i1,i) = i - else - veg_index (i2,i) = i - endif - - end do - - close (10, status ='keep') - -! OCTAD_LOOP : DO NT = 1, NOCTAD - - NT = comm_rank + 1 - ND = 8 - - ! BEGIN READING MODIS FPAR - - MODIS_LOOP : DO year = YearB, YearE - - write (YYYY ,'(i4.4)') year - - WRITE (99,*)'FPAR, VISDF and NIRDF FILES : ' - WRITE (99,*) YYYY//'//fpar.dat' - - open (10, file = trim(BCSDIR)//'MODIS6/'//YYYY//'//fpar.dat', form = 'unformatted', action = 'read') - - if(year < yearE) then - open (11, file = trim(BCSDIR)//'MODIS6/'//YYYY//'//visdf.dat', form = 'unformatted', action = 'read') - open (12, file = trim(BCSDIR)//'MODIS6/'//YYYY//'//nirdf.dat', form = 'unformatted', action = 'read') - WRITE (99,*) YYYY//'//visdf.dat' - WRITE (99,*) YYYY//'//nirdf.dat' - WRITE (99,*) ' ' - endif - - do k = 0, nt ! your processor rank - - read (10) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read (10) modis_fpar (:, year - yearB + 1) - - if ((k > 0) .and.(year < yearE)) then - read (11) modis_visdf (:, year - yearB + 1) - read (12) modis_nirdf (:, year - yearB + 1) - endif - - IF (k == NT) WRITE (99,*) 'PROCESSING TIME SLICE : ', yr,mn,dy,yr1,mn1,dy1 - - end do - - close (10, status = 'keep') - - if(year < yearE) then - close (11, status = 'keep') - close (12, status = 'keep') - endif - - END DO MODIS_LOOP - - ! END READING MODIS FPAR and BEGIN READING CLM4 FPAR - - WRITE (99,*) ' ' - WRITE (99,*) 'READING CLM4 FPAR: ' - - CLM4_LOOP : DO year = YearB, YearE - - octad_time(year - yearB + 1)%year = year - 1 - octad_time(year - yearB + 1)%month = 12 - octad_time(year - yearB + 1)%day = 31 - octad_time(year - yearB + 1)%hour = 0 - octad_time(year - yearB + 1)%min = 0 - octad_time(year - yearB + 1)%sec = 0 - - do k = 1, nt - - if((K == NT).and.(NT == 46)) ND = 5 - - DO day = 1,ND - call augment_date_time( 86400, octad_time(year - yearB + 1)) - - if(k == nt) then - write (YYYY, '(i4.4)') octad_time(year - yearB + 1)%year - write (MM , '(i2.2)') octad_time(year - yearB + 1)%month - write (DD , '(i2.2)') octad_time(year - yearB + 1)%day - YYYYMMDD = YYYY//MM//DD - WRITE (99,*) trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin' - open (10, file = trim(EXPDIR)//'cat/ens_avg/Y'//YYYY//'/M'//MM//'/'// & - trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin', & - form = 'unformatted', convert='big_endian', action = 'read') - - do n = 1,3 - read (10) data_read - if(n == 2) data_save = data_read - end do - - clm4_fpar (:,year - yearB + 1) = clm4_fpar (:,year - yearB + 1) + data_save / (data_read + 1.e-20)/ real (ND) - - close (10, status = 'keep') - - endif - end do - - ND = 8 - - end do - - ! reoder to the order of BCs - - data_read = clm4_fpar (:,year - yearB + 1) - - do n = 1, maxcat - clm4_fpar (LDAS2BCS(n),year - yearB + 1) = data_read (n) - end do - - END DO CLM4_LOOP - - ! Now compute CDFs - ! ---------------- - - ! loop through tiles - - allocate (modis_hist (1:MXCNT)) - allocate (clm4_hist (1:MXCNT)) - allocate (vis_this (1:MXCNT)) - allocate (nir_this (1:MXCNT)) - allocate (fpar_this (1:MXCNT)) - allocate (est_this (1:MXCNT)) - allocate (modis_cdf (1:NBINS)) - allocate (clm4_cdf (1:NBINS)) - - TILE_LOOP : DO ThisTile = 1,NTILES - - NCATCH = NCATCH_ALL (ThisTile) - - if(NCatch < 1) then - WRITE (99,*) 'nSMAP problem ', NCatch, ThisTile - endif - - allocate (Catchs (1: NCatch)) - ! STATUS = NF_GET_VARA_INT (NCInID, VarID(NCInID,'SMAPID'), (/1, ThisTile/), (/NCatch,1/), Catchs) - Catchs (1: NCatch) = Catchs_ALL (1: NCatch, ThisTile) - - PFT_LOOP: DO k =1, NPFT - - modis_hist = 0. - clm4_hist = 0. - modis_cdf = 0. - clm4_cdf = 0. - NDATA1 = 1 - NDATA2 = 1 - N_VIS_DATA = 1 - N_NIR_DATA = 1 - MODIS_BINS = 0. - CLM4_BINS = 0. - - DO year = YearB, YearE - DO N = 1, NCatch - if((veg_index(k,Catchs(n)) > 0).and.(modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) > 0. )) then - modis_hist (NDATA1) = modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) - NDATA1 = NDATA1 + 1 - endif - - if((veg_index(k,Catchs(n)) > 0).and.(clm4_fpar (veg_index(k,Catchs(n)),year - yearB + 1) > 0. )) then - clm4_hist (NDATA2) = clm4_fpar (veg_index(k,Catchs(n)),year - yearB + 1) - NDATA2 = NDATA2 + 1 - endif - - if (year < yearE) then - if((veg_index(k,Catchs(n)) > 0).and.(modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) >= 0. ).and.( modis_visdf(veg_index(k,Catchs(n)), year - yearB + 1) > 0.) & - .and.( modis_nirdf(veg_index(k,Catchs(n)), year - yearB + 1) > 0.)) then - vis_this (N_VIS_DATA) = modis_visdf (veg_index(k,Catchs(n)), year - yearB + 1) - fpar_this(N_VIS_DATA) = modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) - nir_this (N_VIS_DATA) = modis_nirdf (veg_index(k,Catchs(n)), year - yearB + 1) - N_VIS_DATA = N_VIS_DATA + 1 - endif - -! if((veg_index(k,Catchs(n)) > 0).and.(modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) >= 0. ).and.( modis_nirdf(veg_index(k,Catchs(n)), year - yearB + 1) > 0.)) then -! nir_this (N_NIR_DATA) = modis_nirdf (veg_index(k,Catchs(n)), year - yearB + 1) -! N_NIR_DATA = N_NIR_DATA + 1 -! endif - endif - - if((ndata1 > MXCNT).or.(ndata2 > MXCNT).or.(N_VIS_DATA > MXCNT)) then - WRITE (99,*) 'NDATA1 or NDATA2 exceeded ',ndata1, ndata2, N_VIS_DATA, N_NIR_DATA - stop - endif - - END DO - END DO - - NDATA1 = NDATA1 - 1 - NDATA2 = NDATA2 - 1 - N_NIR_DATA = N_NIR_DATA - 1 - N_VIS_DATA = N_VIS_DATA - 1 - - MINV1 = -9999. - MAXV1 = -9999. - MINV2 = -9999. - MAXV2 = -9999. - - ! curve fitting - - modis_param = -9999. - clm4_param = -9999. - FPARmean = -9999. - FPARstd = -9999. - - if((NDATA1 > 10).and.(NDATA2 > 10)) then - - WRITE (99,*) '# of SMAP DATA CELLS ',ThisTile, K, NDATA1,NDATA2, N_NIR_DATA,N_VIS_DATA - - maxv = MAXVAL ((/MAXVAL(modis_hist (1: NDATA1)),MAXVAL(clm4_hist (1: NDATA2))/)) - minv = MINVAL ((/MINVAL(modis_hist (1: NDATA1)),MINVAL(clm4_hist (1: NDATA2))/)) - - if (maxv > minv) then - - modis_hist (1: NDATA1) = (modis_hist (1: NDATA1) - minv)/maxv - call prob_den_func (ndata1, modis_hist (1: NDATA1) , modis_cdf, MODIS_bins, lwval= 0.,upval = 1.) - - dbins = MODIS_bins - dcdf = modis_cdf - modis_param (1) = .5 - modis_param (2) = .5 - modis_param (3) = 0.9 - call optimiz (nbins,dbins,dcdf,modis_param) - - FPARmean = SUM (clm4_hist (1:NDATA2)) / real (NDATA2) - var1 = 0. - - do i = 1,NDATA2 - var1 = var1 + (clm4_hist(i) - FPARmean)*(clm4_hist(i) - FPARmean) - end do - - FPARstd = sqrt (var1/real(NDATA2 - 1)) - - clm4_hist (1: NDATA2) = (clm4_hist (1: NDATA2) - minv)/maxv - call prob_den_func (ndata2, clm4_hist (1: NDATA2) , clm4_cdf, CLM4_bins, lwval= 0.,upval = 1.) - - dbins = CLM4_bins - dcdf = clm4_cdf - clm4_param (1) = .5 - clm4_param (2) = .5 - clm4_param (3) = 0.9 - call optimiz (NBINS,dbins,dcdf,clm4_param) - endif - endif - - ! albedo parameters - - VISmean = -9999. - NIRmean = -9999. - VISstd = -9999. - NIRstd = -9999. - - if (N_VIS_DATA > 12) then - NIRmean = SUM (nir_this (1:N_VIS_DATA)) / real (N_VIS_DATA) - VISmean = SUM (vis_this (1:N_VIS_DATA)) / real (N_VIS_DATA) - - var1 = 0. - var2 = 0. - - do i = 1,N_VIS_DATA - var1 = var1 + (vis_this(i) - VISmean)*(vis_this(i) - VISmean) - var2 = var2 + (nir_this(i) - NIRmean)*(nir_this(i) - NIRmean) - end do - - VISstd = sqrt (var1/real(N_VIS_DATA - 1)) - NIRstd = sqrt (var2/real(N_VIS_DATA - 1)) - - endif - - do i = 1, comm_size - - tmp_real = -9999. - - if((I == 1).and.(comm_rank == 0)) then - - if(put_aux) then - STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,ThisTile,k,NT,1/), (/NBINS,1,1,1,1/), modis_cdf );VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,ThisTile,k,NT,2/), (/NBINS,1,1,1,1/), clm4_cdf );VERIFY_(STATUS) - endif - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Kappa' ),(/ThisTile,k,NT,1/), (/1,1,1,1/), REAL (modis_param(3))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Lambda'),(/ThisTile,k,NT,1/), (/1,1,1,1/), REAL (modis_param(1))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Mu' ),(/ThisTile,k,NT,1/), (/1,1,1,1/), REAL (modis_param(2))) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Kappa' ),(/ThisTile,k,NT,2/), (/1,1,1,1/), REAL (clm4_param(3))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Lambda'),(/ThisTile,k,NT,2/), (/1,1,1,1/), REAL (clm4_param(1))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Mu' ),(/ThisTile,k,NT,2/), (/1,1,1,1/), REAL (clm4_param(2))) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MinVal'),(/ThisTile,k,NT/) , (/1,1,1/), MINV); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MaxVal'),(/ThisTile,k,NT/) , (/1,1,1/), MAXV); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISmean' ),(/ThisTile,k,NT/), (/1,1,1/),VISmean ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRmean' ),(/ThisTile,k,NT/), (/1,1,1/),NIRmean ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISstd' ),(/ThisTile,k,NT/), (/1,1,1/),VISstd ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRstd' ),(/ThisTile,k,NT/), (/1,1,1/),NIRstd ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARmean'),(/ThisTile,k,NT/), (/1,1,1/),FPARmean); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARstd' ),(/ThisTile,k,NT/), (/1,1,1/),FPARstd ); VERIFY_(STATUS);VERIFY_(STATUS) - WRITE (99,*) 'Writing Out OCTAD', ThisTile,k,NT - - else if (I > 1) then - - if(I-1 == comm_rank) then - ! print *, comm_rank, 'sending', ThisTile, k,nt - tmp_real (1) = real (ThisTile) - tmp_real (2) = real(k) - tmp_real (3) = real(NT) - tmp_real (4) = REAL (modis_param(3)) - tmp_real (5) = REAL (modis_param(1)) - tmp_real (6) = REAL (modis_param(2)) - tmp_real (7) = REAL (clm4_param(3)) - tmp_real (8) = REAL (clm4_param(1)) - tmp_real (9) = REAL (clm4_param(2)) - tmp_real(10) = MINV - tmp_real(11) = MINV - tmp_real(12) = MAXV - tmp_real(13) = MAXV - tmp_real(14) = VISmean - tmp_real(15) = NIRmean - tmp_real(16) = VISstd - tmp_real(17) = NIRstd - tmp_real(18) = FPARmean - tmp_real(19) = FPARstd - - NC = 19 - n = NC + NBINS - tmp_real (NC+1: N) = modis_cdf(:) - NC = n - n = NC + NBINS - tmp_real (NC+1: N) = clm4_cdf(:) - NC = n - - call MPI_ISend(tmp_real ,2*NBINS + 19,MPI_real,0,999,MPI_COMM_WORLD,req,status) - call MPI_WAIT (req,MPI_STATUS_IGNORE,status) - - else if (comm_rank == 0) then - - call MPI_RECV(tmp_real,2*NBINS + 19,MPI_real,I-1,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,status) - - IM = NINT (tmp_real (1)) - JM = NINT (tmp_real (2)) - I1 = NINT (tmp_real (3)) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Kappa' ),(/IM,JM,I1,1/), (/1,1,1,1/), tmp_real (4)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Lambda'),(/IM,JM,I1,1/), (/1,1,1,1/), tmp_real (5)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Mu' ),(/IM,JM,I1,1/), (/1,1,1,1/), tmp_real (6)) ; VERIFY_(STATUS) ;VERIFY_(STATUS) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Kappa' ),(/IM,JM,I1,2/), (/1,1,1,1/), tmp_real (7)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Lambda'),(/IM,JM,I1,2/), (/1,1,1,1/), tmp_real (8)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Mu' ),(/IM,JM,I1,2/), (/1,1,1,1/), tmp_real (9)); VERIFY_(STATUS);VERIFY_(STATUS) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'MinVal'),(/IM,JM,I1/) , (/1,1,1/) , tmp_real(10)) ; VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'MaxVal'),(/IM,JM,I1/) , (/1,1,1/) , tmp_real(12)) ; VERIFY_(STATUS) ;VERIFY_(STATUS) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISmean' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(14)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRmean' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(15)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISstd' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(16)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRstd' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(17)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARmean'),(/IM,JM,I1/), (/1,1,1/), tmp_real(18)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARstd' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(19)); VERIFY_(STATUS);VERIFY_(STATUS) - - NC = 19 - n = NC + NBINS - if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,IM,JM,I1,1/), (/NBINS,1,1,1,1/), tmp_real (nc+1: N)); VERIFY_(STATUS) - NC = n - n = NC + NBINS - if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,IM,JM,I1,2/), (/NBINS,1,1,1,1/), tmp_real (nc+1: N)); VERIFY_(STATUS) - NC = n -! n = NC + NBINS -! if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'BINS' ),(/1,IM,JM,I1/) , (/NBINS,1,1,1/) , tmp_real (nc+1: N)); VERIFY_(STATUS) -! NC = n -! n = NC + NBINS -! if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'BINS' ),(/1,IM,JM,I1,2/), (/NBINS,1,1,1,1/), tmp_real (nc+1: N)); VERIFY_(STATUS) - - WRITE (99,*) ' RECEIVED Writing Out OCTAD', I-1,IM,JM,I1 - endif - endif - end do - - END DO PFT_LOOP - - deallocate (Catchs) - - END DO TILE_LOOP - - ! END DO OCTAD_LOOP - if(comm_rank == 0) then - status = NF_CLOSE (NCOutID ) - status = NF_CLOSE (NCOutID2) - endif - close (99, status = 'keep') - - call MPI_BARRIER( MPI_COMM_WORLD, error) - call MPI_Finalize(STATUS) - -STOP - -CONTAINS - -!________________________________________________________________________ - - -SUBROUTINE create_CDF_ParamFile - - implicit none - - integer :: NCFOutID, NCFOutID2, status, pid, tid, did, lid, bid, vid,CID - integer :: i,j, k, n, maxcat,ii,jj, tile_count, nplus, nb, NB_max - integer :: nc_rst = 43200, nr_rst = 21600, DIJ, MXT = 16000 - integer :: PID2, TID2, DID2, LID2,BID2, CID2 - real :: dxy, lw, up, db - real, allocatable, dimension (:) :: abins - integer, allocatable, target, dimension (:,:) :: tile_id - integer, pointer, dimension (:,:) :: tile_id_box - integer, allocatable, dimension (:) :: tile_id_vec, bcs2ldas - integer, allocatable, dimension (:) :: density, loc_int - integer, allocatable, dimension (:) :: loc_val - logical, allocatable, dimension (:) :: unq_mask - character (22) :: time_stamp - integer, dimension(8) :: date_time_values - - - status = NF_CREATE (trim(OUTFIL)//'.nc4' , NF_NETCDF4, NCFOutID );VERIFY_(STATUS) - status = NF_CREATE (trim(OUTFIL)//'_aux.nc4', NF_NETCDF4, NCFOutID2);VERIFY_(STATUS) - ! Define Dimensions - - status = NF_DEF_DIM(NCFOutID, 'pft' , NPFT , PID);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID, 'octad' , NOCTAD, TID);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID, 'data' , NSETS , DID);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID, 'tile10D',NF_UNLIMITED,LID);VERIFY_(STATUS) - - - status = NF_DEF_DIM(NCFOutID2, 'pft' , NPFT , PID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'octad' , NOCTAD, TID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'data' , NSETS , DID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'tile10D',NF_UNLIMITED,LID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'bin' , nbins, BID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'nCELLS' , MXT, CID2);VERIFY_(STATUS) - - ! Define variables - - status = NF_DEF_VAR(NCFOutID, 'lon' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'lat' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'Kappa' , NF_FLOAT ,4 ,(/LID,PID,TID,DID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'Lambda' , NF_FLOAT ,4 ,(/LID,PID,TID,DID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'Mu' , NF_FLOAT ,4 ,(/LID,PID,TID,DID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MinVal' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MaxVal' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISmean', NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRmean', NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISstd' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRstd' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARmean',NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARstd' ,NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'lon' , NF_FLOAT ,1 ,(/LID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'lat' , NF_FLOAT ,1 ,(/LID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'nSMAP' , NF_SHORT ,1 ,(/LID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'BINS' , NF_FLOAT ,1 ,(/BID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'SMAPID', NF_INT ,2 ,(/CID2, LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'CDF' , NF_FLOAT ,5 ,(/BID2,LID2,PID2,TID2,DID2/), vid);VERIFY_(STATUS) - -! Global attributes -! - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) - - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'CreatedBy', LEN_TRIM("Sarith Mahanama"), & - trim("Sarith Mahanama")) - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_PUT_ATT_TEXT(NCFOutID2, NF_GLOBAL, 'CreatedBy', LEN_TRIM("Sarith Mahanama"), & - trim("Sarith Mahanama")) - status = NF_PUT_ATT_TEXT(NCFOutID2, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCFOutID ) - status = NF_ENDDEF(NCFOutID2) - - allocate (abins (1:nbins)) - - lw = 0. - up = 1. - db = (up - lw)/real(nbins) - do n = 1, nbins - abins (n) = lw + real(n)*db - db/2. - end do - - STATUS = NF_PUT_VARA_REAL(NCFOutID2,VARID(NCFOutID2, 'BINS'),(/1/) , (/NBINS/) , abins); VERIFY_(STATUS) - - ! create TILESIZE x TILESIZE tiles at TILEINT - - dij = nint (TILESIZE * nc_rst/360) - dxy = 360./nc_rst - - ! read maxcat from catchment.def - - open (10,file=trim(BCSDIR)//'clsm/catchment.def', status='old',action='read', & - form='formatted') - - read (10,*) maxcat - - close (10, status ='keep') - - ! read tilecoord for tile order in LDASsa - - open (10,file =trim(EXPDIR)//'rc_out/'//trim(EXNAME)//'.ldas_tilecoord.bin',status='old',form='unformatted',convert='big_endian') - read (10) i - if (i /= maxcat) then - print *,'NTILES BCs/LDASsa mismatch:', i,maxcat - stop - endif - - allocate (tile_id_vec (1: maxcat)) - allocate (bcs2ldas (1: maxcat)) - read (10) tile_id_vec - close (10, status = 'keep') - - ! indexing to the LDASsa order - - do i = 1, maxcat - BCS2LDAS(tile_id_vec(i)) = i - end do - - ! read tile_id raster and index according to the order of LDASsa - - open (10,file=trim(BCSDIR)//'rst/'//trim(GFILE)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - ALLOCATE (tile_id (1:nc_rst,1:nr_rst)) - - DO j = 1, nr_rst - read (10) tile_id (:, j) - END DO - - close (10, status ='keep') - - deallocate (tile_id_vec) - - ! find catchment-tiles that contribute to each 10x10 tile - - tile_count = 0 - Nb_max = 0 - - DO J = FLOOR (limits(1) + TILESIZE/2), CEILING (limits (3) - TILESIZE/2), NINT(TILEINT) - DO I = FLOOR (limits(2) + TILESIZE/2), CEILING (limits (4) - TILESIZE/2), NINT(TILEINT) - if (associated (tile_id_box)) NULLIFY (tile_id_box) - jj = (j + 90)*nc_rst/360 - dij/2 - ii = (i + 180)*nc_rst/360 - dij/2 - tile_id_box => tile_id (ii + 1 : ii + dij, jj +1 : jj + dij) - - NPLUS = count(tile_id_box >= 1 .and. tile_id_box <= maxcat) - - if(NPLUS > 0) then - - allocate (loc_int (1:NPLUS)) - allocate (unq_mask(1:NPLUS)) - loc_int = pack(tile_id_box,mask = (tile_id_box >= 1 .and. tile_id_box <= maxcat)) - call MAPL_Sort (loc_int) - unq_mask = .true. - do n = 2,NPLUS - unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) - end do - NB = count(unq_mask) - tile_count = tile_count + 1 - allocate(loc_val (1:NB)) - loc_val = 1.*pack(loc_int,mask =unq_mask) - - IF(NB_MAX < NB) NB_MAX = NB - - if(NB > MXT) then - print *, 'NB EXCEEDED MXT', NB, tile_count - stop - endif - - STATUS = NF_PUT_VARA_INT (NCFOutID2,VARID(NCFOutID2,'nSMAP' ),(/tile_count/), (/1/), NB);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID2,VARID(NCFOutID2,'lat' ),(/tile_count/), (/1/), real(j));VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID2,VARID(NCFOutID2,'lon' ),(/tile_count/), (/1/), real(i));VERIFY_(STATUS) - STATUS = NF_PUT_VARA_INT (NCFOutID2,VARID(NCFOutID2,'SMAPID'),(/1,tile_count/),(/NB, 1/), loc_val);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID ,VARID(NCFOutID, 'lat' ),(/tile_count/), (/1/), real(j));VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID ,VARID(NCFOutID, 'lon' ),(/tile_count/), (/1/), real(i));VERIFY_(STATUS) - -! do k = 1,NBINS -! print *,k, loc_val(k), BCS2LDAS(loc_val(k)) -! STATUS = NF_PUT_VARA_INT (NCFOutID,VARID(NCFOutID,'SMAPID' ),(/k,tile_count/), (/1, 1/), BCS2LDAS(loc_val(k)));VERIFY_(STATUS) -! print *, k,nbins,BCS2LDAS(loc_val(k)) -! end do - deallocate (loc_val,loc_int,unq_mask) - - endif - END DO - END DO - - PRINT *, 'NB_MAX :', NB_MAX - - status = NF_CLOSE (NCFOutID ) - status = NF_CLOSE (NCFOutID2) - - deallocate (abins) - -END SUBROUTINE create_CDF_ParamFile - -! ---------------------------------------------------------------------- - -integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - -end function VarID - -! ----------------------------------------------------------------------- - -SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',STATUS, NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - -END SUBROUTINE HANDLE_ERR - -! ---------------------------------------------------------------------- - -SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) - - implicit none - - integer, intent (in) :: NBINS, NLENS - real, intent (in) :: x (NLENS) - integer, intent (out):: density (NBINS) - real, intent (inout) :: loc_val (NBINS) - real, intent (in), optional :: bin - real :: xdum(NLENS), xl, xu, min_value - integer :: n - - if(present (bin)) min_value = real(floor(minval(x))) - - DO N = 1, NBINS - if(present (bin)) then - xl = (N - 1)*BIN + min_value - loc_val (n) = xl - xu = xl + bin - XDUM = 0. - where((x >= xl).and.(x < xu))XDUM = 1 - else - XDUM = 0. - where(x == loc_val (n)) XDUM = 1 - endif - density(n) = int(sum(XDUM)) - END DO - -END SUBROUTINE HISTOGRAM - -!---------------------------------------------------------------------- - -END PROGRAM comp_FPAR_CDF diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 42d3fe363..98900a487 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -234,14 +234,3 @@ # # GEOSagcm=>PRESCRIBE_DVG: 0 # GEOSldas=>PRESCRIBE_DVG: 0 - -# ---- Scale CATCHCN ALBEDO and FPAR -# -# 0 : NO scaling is performed (default) -# 1 : Scale albedo to match interannually varying MODIS NIRDF and VISDF anomaly -# 2 : Scale albedo to match CDFs of model fPAR to MODIS CDFs of fPAR -# 3 : Perform both 1 and 2 above -# -# GEOSagcm=>SCALE_ALBFPAR: 0 -# GEOSldas=>SCALE_ALBFPAR: 0 - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt index 98956b0cd..21d1777ea 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt @@ -9,7 +9,6 @@ rasterize.F90 read_riveroutlet.F90 CubedSphere_GridMod.F90 rmTinyCatchParaMod.F90 -comp_CATCHCN_AlbScale_parameters.F90 zip.c util.c ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 deleted file mode 100644 index 16bd9f0f2..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 +++ /dev/null @@ -1,835 +0,0 @@ -#define VERIFY_(A) IF(A/=0)THEN;PRINT *,'ERROR AT LINE ', __LINE__;STOP;ENDIF -#define ASSERT_(A) if(.not.A)then;print *,'Error:',__FILE__,__LINE__;stop;endif - -MODULE comp_CATCHCN_AlbScale_parameters - - use date_time_util, ONLY: & - date_time_type, augment_date_time - - implicit none - INCLUDE 'netcdf.inc' - - private - - public :: albedo4catchcn - - character*400, PARAMETER :: & - InBCSDIR = '/discover/nobackup/smahanam/MERRA3/FPAR/SMAP_EASEv2_M09/', & - !EXPDIR = '/archive/u/smahanam/FPAR-ALB/e0004s_wet2/output/SMAP_EASEv2_M09_GLOBAL/', & - EXPDIR = '/discover/nobackup/borescan/BCS/add_to_l_land/e0004s_wet2/output/SMAP_EASEv2_M09_GLOBAL/', & - EXNAME = 'e0004s_wet2', & - InGFILE = 'SMAP_EASEv2_M09_3856x1624' - - ! character*400 :: GFILE = 'til/CF0180x6C_TM0720xTM0410-Pfafstetter.til' - real, parameter :: MAPL_PI = 3.14159265358979323846d0 - integer, parameter :: yearB = 2001, yearE = 2015, InNTILES = 1684725, NOCTAD = 46 - integer, parameter :: yearB1= 2002 - contains - - SUBROUTINE albedo4catchcn (gfile) - - implicit none - character (*), intent (in) :: gfile - integer :: NTILES - integer, dimension (:), allocatable :: id_loc - - call preprocess_m09 - open (10, file = 'clsm/catchment.def', form = 'formatted', status= 'old', action = 'read') - read (10, *) NTILES - close (10, status = 'keep') - - allocate (id_loc (1: NTILES)) - - call get_id_loc (NTILES, trim (GFILE)//'.til', id_loc) - call regrid_alb (NTILES, id_loc) - - end SUBROUTINE albedo4catchcn - - ! ------------------------------------------------------------------------------- - - SUBROUTINE get_id_loc (NT, gfile, id_loc) - - implicit none - - integer, intent (in) :: NT - integer, dimension (NT), intent (inout) :: id_loc - character(*), intent (in) :: gfile - integer :: n, i, nplus, t_count - real, dimension (:), allocatable :: lon, lat, m09_lon, m09_lat, tid_m09 - integer, allocatable, dimension (:) :: sub_tid - real , allocatable, dimension (:) :: sub_lon, sub_lat, rev_dist - real :: dw, dx, dy, min_lon, max_lon, min_lat, max_lat - logical :: tile_found - logical, allocatable, dimension(:) :: mask - integer, allocatable :: low_ind(:), upp_ind(:) - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1 -! -! -! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! -! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION -! -!$ running_omp = .true. ! conditional compilation -! -! ECHO BASIC OMP VARIABLES -! -!$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) -! -!$OMP SINGLE -! -!$ n_threads = omp_get_num_threads() -! -!$ write (*,*) 'running_omp = ', running_omp -!$ write (*,*) -!$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' -!$ write (*,*) -!$OMP ENDSINGLE -! -!$OMP CRITICAL -!$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' -!$OMP ENDCRITICAL -! -!$OMP BARRIER -! -!$OMP ENDPARALLEL - - allocate (lon (1: NT)) - allocate (lat (1: NT)) - allocate (m09_lon (1: InNTILES)) - allocate (m09_lat (1: InNTILES)) - allocate (tid_m09 (1: InNTILES)) - - call ReadCNTilFile (trim(InBCSDIR)//trim(InGFILE)//'.til', InNTILES, m09_lon, m09_lat) - call ReadCNTilFile (trim(GFILE), NT, lon, lat) - - Id_loc = -9999 - do n = 1, InNTILES - tid_m09(n) = n - end do - - ! Domain decomposition - ! -------------------- - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = nt - - if (running_omp) then - do i=1,n_threads-1 - upp_ind(i) = low_ind(i) + (NT/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - ! print *,i,low_ind(i),upp_ind(i) - end do - ! print *,i,low_ind(i),upp_ind(i) - end if - -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( n_threads, low_ind, upp_ind, Id_loc, & -!$OMP lon, lat, m09_lon, m09_lat, tid_m09) & -!$OMP PRIVATE(n,i,t_count,min_lon, max_lon, min_lat, max_lat, & -!$OMP sub_tid, nplus, sub_lon, sub_lat, rev_dist, dw, & -!$OMP tile_found, mask) - - DO t_count = 1,n_threads - - allocate (mask (1: InNTILES)) - - OUT_TILES : do n = low_ind(t_count),upp_ind(t_count) - if(MOD(n,10000) == 0) print *,'In ID_LOC', t_count,n - dw = 0.25 - - ZOOMOUT : do - - tile_found = .false. - - ! Min/Max lon/lat of the working window - ! ------------------------------------- - - min_lon = MAX(lon (n) - dw, -180.) - max_lon = MIN(lon (n) + dw, 180.) - min_lat = MAX(lat (n) - dw, -90.) - max_lat = MIN(lat (n) + dw, 90.) - - mask = .false. - mask = ((m09_lat >= min_lat .and. m09_lat <= max_lat).and.(m09_lon >= min_lon .and. m09_lon <= max_lon)) - nplus = count(mask = mask) - - if(nplus < 0) then - dw = dw + 0.5 - CYCLE - endif - - allocate (sub_tid (1:nplus)) - allocate (sub_lon (1:nplus)) - allocate (sub_lat (1:nplus)) - allocate (rev_dist(1:nplus)) - - sub_tid = PACK (tid_m09 , mask= mask) - sub_lon = PACK (m09_lon , mask= mask) - sub_lat = PACK (m09_lat , mask= mask) - - ! compute distance from the tile - - sub_lat = sub_lat * MAPL_PI/180. - sub_lon = sub_lon * MAPL_PI/180. - - SEEK : if(Id_loc(n) < 0) then - - rev_dist = 1.e20 - - do i = 1,nplus - - rev_dist(i) = haversine(to_radian(lat(n)), to_radian(lon(n)), & - sub_lat(i), sub_lon(i)) - - end do - - FOUND : if(minval (rev_dist) < 1.e19) then - Id_loc(n) = sub_tid(minloc(rev_dist,1)) - tile_found = .true. - - if(Id_loc(n) ==0) then - print *, rev_dist - print *, sub_tid - print *, minval (rev_dist) - print *, minloc(rev_dist,1) - stop - endif - endif FOUND - - endif SEEK - - deallocate (sub_tid, sub_lon, sub_lat, rev_dist) - - if(tile_found) GO TO 100 - - ! if not increase the window size - dw = dw + 0.25 - - end do ZOOMOUT - -100 continue - - END do OUT_TILES - - deallocate (mask) - - end DO ! PARALLEL - -!$OMP ENDPARALLELDO - - END SUBROUTINE get_id_loc - - ! ***************************************************************************** - - function to_radian(degree) result(rad) - - ! degrees to radians - real,intent(in) :: degree - real :: rad - - rad = degree*MAPL_PI/180. - - end function to_radian - - ! ------------------------------------------------------------------------------------------------- - - SUBROUTINE regrid_alb (NTILES, id_loc) - - implicit none - integer, intent (in) :: NTILES - integer, dimension (NTILES), intent (in) :: id_loc - character*10 :: string - integer :: STATUS, ncid, NCOutID, t, time_slice, time_slice_next, yr, mn, dd, yr1, mn1, dd1, n_tslices - character (len=4), dimension (:), allocatable :: MMDD, MMDD_next - real, allocatable, dimension (:) :: varin, varout - - n_tslices = NOCTAD - - status = NF_OPEN('data/CATCH/MODIS-Albedo2/MCD43GF_wsa_H11V13.nc',NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - allocate (varin (1:InNTILES)) - allocate (varout(1:NTILES)) - - STATUS = NF_OPEN('data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', NF_NOWRITE,NCOutID) ; VERIFY_(STATUS) - open (10, file = 'clsm/MODISVISmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (11, file = 'clsm/MODISNIRmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (12, file = 'clsm/MODISVISstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (13, file = 'clsm/MODISNIRstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (14, file = 'clsm/MODELFPARmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (15, file = 'clsm/MODELFPARstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (16, file = 'clsm/MODISFPARmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (17, file = 'clsm/MODISFPARstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write(10) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(11) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(12) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(13) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(14) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(15) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(16) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(17) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (10) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (11) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (12) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (13) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (14) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (15) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (16) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (17) varout - end do - - deallocate (varin, varout) - - close (10 , status = 'keep') - close (11 , status = 'keep') - close (12 , status = 'keep') - close (13 , status = 'keep') - close (14 , status = 'keep') - close (15 , status = 'keep') - close (16 , status = 'keep') - close (17 , status = 'keep') - - END SUBROUTINE regrid_alb - - ! ------------------------------------------------------------------------------------------------- - - SUBROUTINE preprocess_m09 - - implicit none - logical :: file_exists - INTEGER :: NT, ND, DAY, year, STATUS, NCOutID, k - CHARACTER*8 :: YYYYMMDD - CHARACTER*6 :: YYYYMM - CHARACTER*4 :: YYYY - CHARACTER*2 :: MM, DD - real :: yr,mn,dy,dum,yr1,mn1,dy1 - - real, allocatable, dimension (:,:) :: MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR - real, allocatable, dimension (:) :: data_read, data_save, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd, & - MODISFPARmean, MODISFPARstd - integer, allocatable, dimension (:) :: ldas2bcs - type(date_time_type), dimension (YearE - YearB + 1) :: octad_time - - - inquire(file='data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', exist=file_exists) - if(.not. file_exists) call create_stat_file - -! open (99,file='clsm/comp_CATCHCN_AlbScale_parameters.log', form ='formatted', action='write', status= 'unknown') - - STATUS = NF_OPEN ('data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', NF_WRITE,NCOutID) ; VERIFY_(STATUS) - - allocate (MODIS_VISDF (1:InNTILES, yearE - yearB + 1)) - allocate (MODIS_NIRDF (1:InNTILES, yearE - yearB + 1)) - allocate (MODEL_fPAR (1:InNTILES, yearE - yearB + 1)) - allocate (ldas2bcs (1:InNTILES)) - allocate (data_read (1:InNTILES)) - allocate (data_save (1:InNTILES)) - allocate (MODISVISmean (1:InNTILES)) - allocate (MODISNIRmean (1:InNTILES)) - allocate (MODISVISstd (1:InNTILES)) - allocate (MODISNIRstd (1:InNTILES)) - allocate (MODELFPARmean(1:InNTILES)) - allocate (MODELFPARstd (1:InNTILES)) - allocate (MODISFPARmean(1:InNTILES)) - allocate (MODISFPARstd (1:InNTILES)) - - open (10,file =trim(EXPDIR)//'rc_out/'//trim(EXNAME)//'.ldas_tilecoord.bin',status='old',form='unformatted',convert='big_endian') - read (10) k - read (10) LDAS2BCS - close(10, status = 'keep') - - OPEN_FILES1 : DO year = YearB, YearE - - write (YYYY ,'(i4.4)') year - open (10 + year - yearB, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//visdf.dat', form = 'unformatted', action = 'read') - open (30 + year - yearB, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//nirdf.dat', form = 'unformatted', action = 'read') -! WRITE (99,*)10 + year - yearB, YYYY//'//visdf.dat' -! WRITE (99,*)30 + year - yearB, YYYY//'//nirdf.dat' -! WRITE (99,*) ' ' - WRITE (*,*)10 + year - yearB, YYYY//'//visdf.dat' - WRITE (*,*)30 + year - yearB, YYYY//'//nirdf.dat' - WRITE (*,*) ' ' - octad_time(year - yearB + 1)%year = year - 1 - octad_time(year - yearB + 1)%month = 12 - octad_time(year - yearB + 1)%day = 31 - octad_time(year - yearB + 1)%hour = 0 - octad_time(year - yearB + 1)%min = 0 - octad_time(year - yearB + 1)%sec = 0 - - END DO OPEN_FILES1 - - ND = 8 - - OCTAD_LOOP : DO NT = 1, NOCTAD - - ! BEGIN READING MODIS VISDF/NIRDF - - MODIS_VISDF = 0. - MODIS_NIRDF = 0. - MODEL_fPAR = 0. - - if(NT == NOCTAD) ND = 5 -! WRITE (99,*) NT, ND, yearB, yearE - print *, NT, ND, yearB, yearE - - READ_YEARS : DO year = YearB, YearE - - read (10 + year - yearB) modis_visdf (:, year - yearB + 1) - read (30 + year - yearB) modis_nirdf (:, year - yearB + 1) - - DAILY_LOOP : DO day = 1,ND - - call augment_date_time(86400, octad_time(year - yearB + 1)) - - write (YYYY, '(i4.4)') octad_time(year - yearB + 1)%year - write (MM , '(i2.2)') octad_time(year - yearB + 1)%month - write (DD , '(i2.2)') octad_time(year - yearB + 1)%day - - YYYYMMDD = YYYY//MM//DD -! WRITE (99,*) trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin' - print *, trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin' - open (60, file = trim(EXPDIR)//'cat/ens_avg/Y'//YYYY//'/M'//MM//'/'// & - trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin', & - form = 'unformatted', convert='big_endian', action = 'read') - - do k = 1,3 - read (60) data_read - if(k == 2) data_save = data_read - end do - - MODEL_fPAR (:,year - yearB + 1) = MODEL_fPAR (:,year - yearB + 1) + data_save / (data_read + 1.e-20)/ real (ND) - close (60, status = 'keep') - - END DO DAILY_LOOP - - ! reoder to the order of BCs - - data_read = MODEL_fPAR (:,year - yearB + 1) - - do k = 1, InNTILES - MODEL_fPAR (LDAS2BCS(k),year - yearB + 1) = data_read (k) - end do - END DO READ_YEARS - - ! COMPUTE STATS - - CALL compute_stats (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd) - - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISmean' ),(/1,NT/), (/InNTILES,1/), MODISVISmean ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRmean' ),(/1,NT/), (/InNTILES,1/), MODISNIRmean ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISstd' ),(/1,NT/), (/InNTILES,1/), MODISVISstd ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRstd' ),(/1,NT/), (/InNTILES,1/), MODISNIRstd ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARmean' ),(/1,NT/), (/InNTILES,1/), MODELFPARmean) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARstd' ),(/1,NT/), (/InNTILES,1/), MODELFPARstd ) ; VERIFY_(STATUS) - - END DO OCTAD_LOOP - - CLOSE_FILES1 : DO year = YearB, YearE - - close (10 + year - yearB, status = 'keep') - close (30 + year - yearB, status = 'keep') - - END DO CLOSE_FILES1 - - ! MODIS FPAR - ! ---------- - - deallocate (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR) - allocate (MODIS_VISDF (1:InNTILES, yearE - yearB1 + 1)) - allocate (MODIS_NIRDF (1:InNTILES, yearE - yearB1 + 1)) - allocate (MODEL_fPAR (1:InNTILES, yearE - yearB1 + 1)) - - OPEN_FILES2 : DO year = YearB1, YearE - - write (YYYY ,'(i4.4)') year - open (10 + year - yearB1, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//visdf.dat', form = 'unformatted', action = 'read') - open (30 + year - yearB1, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//nirdf.dat', form = 'unformatted', action = 'read') - open (50 + year - yearB1, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//fpar.dat', form = 'unformatted', action = 'read') -! WRITE (99,*) " " -! WRITE (99,*) "MODIS FPAR" -! WRITE (99,*) "==========" -! WRITE (99,*) " " - -! WRITE (99,*)10 + year - yearB1, YYYY//'//visdf.dat' -! WRITE (99,*)30 + year - yearB1, YYYY//'//nirdf.dat' -! WRITE (99,*)50 + year - yearB1, YYYY//'//fpar.dat' -! WRITE (99,*) ' ' - WRITE (*,*)10 + year - yearB1, YYYY//'//visdf.dat' - WRITE (*,*)30 + year - yearB1, YYYY//'//nirdf.dat' - WRITE (*,*)50 + year - yearB1, YYYY//'//fpar.dat' - WRITE (*,*) ' ' - read (50 + year - yearB1) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - WRITE (*,*) yr,mn,dy,yr1,mn1,dy1 - read (50 + year - yearB1) MODEL_FPAR (:, year - yearB1 + 1) - - octad_time(year - yearB1 + 1)%year = year - 1 - octad_time(year - yearB1 + 1)%month = 12 - octad_time(year - yearB1 + 1)%day = 31 - octad_time(year - yearB1 + 1)%hour = 0 - octad_time(year - yearB1 + 1)%min = 0 - octad_time(year - yearB1 + 1)%sec = 0 - - END DO OPEN_FILES2 - - ND = 8 - - OCTAD_LOOP2 : DO NT = 1, NOCTAD - - ! BEGIN READING MODIS VISDF/NIRDF/FPAR - - MODIS_VISDF = 0. - MODIS_NIRDF = 0. - MODEL_fPAR = 0. - - if(NT == NOCTAD) ND = 5 -! WRITE (99,*) NT, ND, yearB1, yearE - print *, NT, ND, yearB1, yearE - READ_YEARS2 : DO year = YearB1, YearE - - read (10 + year - yearB1) modis_visdf (:, year - yearB1 + 1) - read (30 + year - yearB1) modis_nirdf (:, year - yearB1 + 1) - read (50 + year - yearB1) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - WRITE (*,*) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read (50 + year - yearB1) MODEL_FPAR (:, year - yearB1 + 1) - END DO READ_YEARS2 - - ! COMPUTE STATS - - CALL compute_stats (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd) - - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARmean' ),(/1,NT/), (/InNTILES,1/), MODELFPARmean) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARstd' ),(/1,NT/), (/InNTILES,1/), MODELFPARstd ) ; VERIFY_(STATUS) - - END DO OCTAD_LOOP2 - - CLOSE_FILES2 : DO year = YearB1, YearE - - close (10 + year - yearB1, status = 'keep') - close (30 + year - yearB1, status = 'keep') - close (50 + year - yearB1, status = 'keep') - - END DO CLOSE_FILES2 - - STATUS = NF_CLOSE (NCOutID ) - - END SUBROUTINE preprocess_m09 - - ! ----------------------------------------------------------------- - - SUBROUTINE create_stat_file - - implicit none - - integer :: NCFOutID, STATUS, vid, tid, lid, n, k - character (22) :: time_stamp, tmpstr - integer, dimension(8) :: date_time_values - real, dimension (:), allocatable :: lons, lats - - STATUS = NF_CREATE ('data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', NF_NETCDF4, NCFOutID );VERIFY_(STATUS) - STATUS = NF_DEF_DIM(NCFOutID, 'octad', NOCTAD, TID) ; VERIFY_(STATUS) - STATUS = NF_DEF_DIM(NCFOutID, 'tiles', InNTILES, LID) ; VERIFY_(STATUS) - STATUS = NF_DEF_VAR(NCFOutID, 'lon' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - STATUS = NF_DEF_VAR(NCFOutID, 'lat' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISmean', NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRmean', NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISstd' , NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRstd' , NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARmean',NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARstd' ,NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISFPARmean',NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISFPARstd' ,NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - ! Global attributes - - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) - - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'CreatedBy', LEN_TRIM("Sarith Mahanama"), & - trim("Sarith Mahanama")) - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCFOutID ) - - ! Read and put lat/lon data - - allocate (lons (1:InNTILES)) - allocate (lats (1:InNTILES)) - - open (10, file = trim(InBCSDIR)//trim(InGFILE)//'.til', form = 'formatted', status = 'old') - - do n = 1,8 - read (10,*) tmpstr - end do - - do n = 1, InNTILES - read (10,*) k, k, lons(n), lats(n) - end do - - close (10, status = 'keep') - - STATUS = NF_PUT_VARA_REAL(NCFOutID,VARID(NCFOutID,'lon' ),(/1/), (/InNTILES/), lons) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID,VARID(NCFOutID,'lat' ),(/1/), (/InNTILES/), lats) ; VERIFY_(STATUS) - - STATUS = NF_CLOSE (NCFOutID ) - - END SUBROUTINE create_stat_file - - ! ---------------------------------------------------------------------- - - SUBROUTINE compute_stats (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd) - - implicit none - real, dimension (:,:), intent (in) :: MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR - real, dimension (:) , intent (inout) :: MODISVISmean, MODISNIRmean, MODISVISstd, & - MODISNIRstd, MODELFPARmean, MODELFPARstd - integer :: NX, NY, N, t - REAL :: MF, MV, MN, SF, SV, SN, ZV, ZN, CV, CN, CF - - NX = size (MODIS_VISDF,1) - NY = size (MODIS_VISDF,2) - print *,'Entered compute_stats', NX, NY - if (NX /= InNTILES) then - print *, 'NX NTILLES MISMAATCH : ', InNTILES, NX, NY - STOP - ENDIF - - DO N = 1, NX - -! MF = SUM (MODEL_fPAR (N,:)) / REAL (NY) -! MV = SUM (MODIS_VISDF (N,:)) / REAL (NY) -! MN = SUM (MODIS_nirDF (N,:)) / REAL (NY) - MF = 0. - MV = 0. - MN = 0. - CV = 0. - CN = 0. - CF = 0. - - do T = 1, NY - if ((MODEL_fPAR (N,T) >= 0.).AND.(MODEL_fPAR (N,T) <= 1.)) then - MF = MF + MODEL_fPAR (N,T) - CF = CF + 1. - endif - if ((MODIS_VISDF (N,T) >= 0.).AND.(MODIS_VISDF (N,T) <= 1.)) then - MV = MV + MODIS_VISDF (N,T) - CV = CV + 1. - endif - if ((MODIS_NIRDF (N,T) >= 0.).AND.(MODIS_NIRDF (N,T) <= 1.)) then - MN = MN + MODIS_NIRDF (N,T) - CN = CN + 1. - endif - end do - - IF(CF > 0) MF = MF / CF - IF(CV > 0) MV = MV / CV - IF(CN > 0) MN = MN / CN - - ! STANDARD DEVIATION - - SF = 1.e-15 - SV = 1.e-15 - SN = 1.e-15 - - do T = 1, NY - if ((MODEL_fPAR (N,T) >= 0.).AND.(MODEL_fPAR (N,T) <= 1.)) SF = SF + (MODEL_fPAR (N,t) - MF)*(MODEL_fPAR (N,t) - MF) - if ((MODIS_VISDF (N,T) >= 0.).AND.(MODIS_VISDF (N,T) <= 1.)) SV = SV + (MODIS_VISDF (N,t) - MV)*(MODIS_VISDF (N,t) - MV) - if ((MODIS_NIRDF (N,T) >= 0.).AND.(MODIS_NIRDF (N,T) <= 1.)) SN = SN + (MODIS_NIRDF (N,t) - MN)*(MODIS_NIRDF (N,t) - MN) - end do - - IF(CF > 0) SF = SQRT (SF / CF) - IF(CV > 0) SV = SQRT (SV / CV) - IF(CN > 0) SN = SQRT (SN / CN) - - ! CORRELATION - - ZV = 0. - ZN = 0. - - DO T = 1, NY - ZV = ZV + (MODEL_fPAR (N,t) - MF)*(MODIS_VISDF (N,t) - MV)/SF/SV - ZN = ZN + (MODEL_fPAR (N,t) - MF)*(MODIS_NIRDF (N,t) - MN)/SF/SV - END DO - - ZV = ZV / REAL (NY) - ZN = ZN / REAL (NY) - - MODISVISmean (N) = MV - MODISNIRmean (N) = MN - MODISVISstd (N) = SV - MODISNIRstd (N) = SN - MODELFPARmean(N) = MF - MODELFPARstd (N) = SF - - if(ZV < 0.) MODISVISstd (N) = -1. * MODISVISstd (N) - if(Zn < 0.) MODISnirstd (N) = -1. * MODISnirstd (N) - - END DO - - print *,'Leaving compute_stats' - - END SUBROUTINE compute_stats - - ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',STATUS, NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - subroutine ReadCNTilFile (InCNTileFile, nt, xlon, xlat) - - implicit none - character(*), intent (in) :: InCNTileFile - integer , intent (in) :: nt - real, dimension (nt), intent(inout) :: xlon, xlat - integer :: n,icnt,ityp - real :: xval,yval, pf - - open(11,file=InCNTileFile, & - form='formatted',action='read',status='old') - - do n = 1,8 ! skip header - read(11,*) - end do - - icnt = 0 - ityp = 100 - - do while (ityp == 100) ! loop over land tiles - read(11,*) ityp,pf,xval,yval - if(ityp == 100) then - icnt = icnt + 1 - xlon(icnt) = xval - xlat(icnt) = yval - endif - end do - - close(11) - - end subroutine ReadCNTilFile - - ! ***************************************************************************** - - real function haversine(deglat1,deglon1,deglat2,deglon2) - ! great circle distance -- adapted from Matlab - real,intent(in) :: deglat1,deglon1,deglat2,deglon2 - real :: a,c, dlat,dlon,lat1,lat2 - real,parameter :: radius = 6371.0E3 - -! dlat = to_radian(deglat2-deglat1) -! dlon = to_radian(deglon2-deglon1) - ! lat1 = to_radian(deglat1) -! lat2 = to_radian(deglat2) - dlat = deglat2-deglat1 - dlon = deglon2-deglon1 - lat1 = deglat1 - lat2 = deglat2 - a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 - if(a>=0. .and. a<=1.) then - c = 2*atan2(sqrt(a),sqrt(1-a)) - haversine = radius*c / 1000. - else - haversine = 1.e20 - endif - end function - - ! ***************************************************************************** - - END MODULE comp_CATCHCN_AlbScale_parameters diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs index e21883729..e614afbf1 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs @@ -780,14 +780,6 @@ cd clsm.${IM}x${JM} /bin/mv green.dat green_clim_${RS}_DC.data /bin/mv lnfm.dat lnfm_clim_${RS}_DC.data /bin/mv ndvi.dat ndvi_clim_${RS}_DC.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RS}_DC.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RS}_DC.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RS}_DC.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RS}_DC.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RS}_DC.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RS}_DC.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RS}_DC.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RS}_DC.dat /bin/rm -f sedfile cat > sedfile << EOF @@ -1010,14 +1002,6 @@ cd clsm.C${NC} /bin/mv green.dat green_clim_${RC}.data /bin/mv lnfm.dat lnfm_clim_${RC}.data /bin/mv ndvi.dat ndvi_clim_${RC}.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RC}.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RC}.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RC}.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RC}.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RC}.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RC}.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RC}.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RC}.dat /bin/rm -f sedfile if( $CUBED_SPHERE_OCEAN == TRUE ) then @@ -1175,14 +1159,6 @@ cd clsm.C${NC} /bin/mv green.dat green_clim_${RC}.data /bin/mv lnfm.dat lnfm_clim_${RC}.data /bin/mv ndvi.dat ndvi_clim_${RC}.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RC}.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RC}.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RC}.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RC}.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RC}.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RC}.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RC}.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RC}.dat /bin/rm -f sedfile if( $CUBED_SPHERE_OCEAN == TRUE ) then @@ -1357,14 +1333,6 @@ cd clsm.${IM}x${JM} /bin/mv green.dat green_clim_${RS}_DE.data /bin/mv lnfm.dat lnfm_clim_${RS}_DE.data /bin/mv ndvi.dat ndvi_clim_${RS}_DE.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RS}_DE.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RS}_DE.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RS}_DE.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RS}_DE.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RS}_DE.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RS}_DE.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RS}_DE.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RS}_DE.dat cd ../ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index 877a3c7ec..7a32853c7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -23,7 +23,6 @@ PROGRAM mkCatchParam use rmTinyCatchParaMod use process_hres_data - use comp_CATCHCN_AlbScale_parameters, ONLY : albedo4catchcn ! use module_irrig_params, ONLY : create_irrig_params implicit none @@ -665,7 +664,6 @@ PROGRAM mkCatchParam ! if (.not.file_exists) call create_irrig_params (nc,nr,gridnamer) ! write (log_file,'(a)')'Done computing irrigation model parameters ...............13' - ! call albedo4catchcn (gridnamet) write (log_file,'(a)')'============================================================' write (log_file,'(a)')'DONE creating CLSM data files...............................' From 87a2ddcf3b6517cb0dbf1f148e2b51fa0729ef0b Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Mon, 23 May 2022 11:00:10 -0400 Subject: [PATCH 17/21] removed math_routines.F90, commented out obsolete functions betai(), betacf(), gammaln() --- .../GEOS_CatchCNCLM40GridComp.F90 | 195 +-- .../GEOS_CatchCNCLM45GridComp.F90 | 195 +-- .../utils/math_routines.F90 | 1186 ----------------- 3 files changed, 202 insertions(+), 1374 deletions(-) delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index 5e95efd27..f554a0bbf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -7710,102 +7710,109 @@ subroutine Driver ( RC ) end subroutine Driver - - FUNCTION betai(a,b,x) - REAL betai,a,b,x - REAL bt - !external gammln - - if (x < 0.0125) x = 0.0125 - if (x > 0.9875) x = 0.9875 - - if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x - if(x.lt.0..or.x.gt.1.)stop - if(x.eq.0..or.x.eq.1.)then - bt=0. - else - bt=exp(gammln(a+b)-gammln(a)-gammln(b) & - +a*log(x)+b*log(1.-x)) - endif - - if(x.lt.(a+1.)/(a+b+2.))then - betai=bt*betacf(a,b,x)/a - return - else - betai=1.-bt*betacf(b,a,1.-x)/b - return - endif - - END FUNCTION betai - - ! ------------------------------------------------------- - FUNCTION betacf(a,b,x) - - INTEGER MAXIT - REAL betacf,a,b,x,EPS,FPMIN - PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) - INTEGER m,m2 - REAL aa,c,d,del,h,qab,qam,qap - - qab=a+b - qap=a+1. - qam=a-1. - c=1. - d=1.-qab*x/qap - - if(abs(d).lt.FPMIN)d=FPMIN - d=1./d - h=d - do m=1,MAXIT - m2=2*m - aa=m*(b-m)*x/((qam+m2)*(a+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - h=h*d*c - aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - del=d*c - h=h*del - if(abs(del-1.).lt.EPS)exit - enddo - betacf=h - return - - END FUNCTION betacf +! Commented out functions betai(), betacf(), and gammln(). +! These functions are not used and were reproduced identically in +! GEOS_CatchCNCLM40GridComp.F90 and in GEOS_CatchCNCLM45GridComp.F90. +! Another copy was in GEOScatchCN_GridComp/utils/math_routines.F90 but +! there function betai() was missing the restriction 0.0125 0.9875) x = 0.9875 +!! +!! if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x +!! if(x.lt.0..or.x.gt.1.)stop +!! if(x.eq.0..or.x.eq.1.)then +!! bt=0. +!! else +!! bt=exp(gammln(a+b)-gammln(a)-gammln(b) & +!! +a*log(x)+b*log(1.-x)) +!! endif +!! +!! if(x.lt.(a+1.)/(a+b+2.))then +!! betai=bt*betacf(a,b,x)/a +!! return +!! else +!! betai=1.-bt*betacf(b,a,1.-x)/b +!! return +!! endif +!! +!! END FUNCTION betai +!! +!! ! ------------------------------------------------------- +!! +!! FUNCTION betacf(a,b,x) +!! +!! INTEGER MAXIT +!! REAL betacf,a,b,x,EPS,FPMIN +!! PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) +!! INTEGER m,m2 +!! REAL aa,c,d,del,h,qab,qam,qap +!! +!! qab=a+b +!! qap=a+1. +!! qam=a-1. +!! c=1. +!! d=1.-qab*x/qap +!! +!! if(abs(d).lt.FPMIN)d=FPMIN +!! d=1./d +!! h=d +!! do m=1,MAXIT +!! m2=2*m +!! aa=m*(b-m)*x/((qam+m2)*(a+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! h=h*d*c +!! aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! del=d*c +!! h=h*del +!! if(abs(del-1.).lt.EPS)exit +!! enddo +!! betacf=h +!! return +!! +!! END FUNCTION betacf +!! +!! ! -------------------------------------------------------------- +!! +!! FUNCTION gammln(xx) +!! +!! REAL gammln,xx +!! INTEGER j +!! DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) +!! +!! SAVE cof,stp +!! DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & +!! 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & +!! -.5395239384953d-5,2.5066282746310005d0/ +!! x=xx +!! y=x +!! tmp=x+5.5d0 +!! tmp=(x+0.5d0)*log(tmp)-tmp +!! ser=1.000000000190015d0 +!! do j=1,6 +!! y=y+1.d0 +!! ser=ser+cof(j)/y +!! enddo +!! gammln=tmp+log(stp*ser/x) +!! return +!! +!! END FUNCTION gammln ! -------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index e5b6680e5..f1b24d30e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -8013,101 +8013,108 @@ subroutine Driver ( RC ) end subroutine Driver - FUNCTION betai(a,b,x) - REAL betai,a,b,x - REAL bt - !external gammln - - if (x < 0.0125) x = 0.0125 - if (x > 0.9875) x = 0.9875 - - if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x - if(x.lt.0..or.x.gt.1.)stop - if(x.eq.0..or.x.eq.1.)then - bt=0. - else - bt=exp(gammln(a+b)-gammln(a)-gammln(b) & - +a*log(x)+b*log(1.-x)) - endif - - if(x.lt.(a+1.)/(a+b+2.))then - betai=bt*betacf(a,b,x)/a - return - else - betai=1.-bt*betacf(b,a,1.-x)/b - return - endif - - END FUNCTION betai - - ! ------------------------------------------------------- - - FUNCTION betacf(a,b,x) - - INTEGER MAXIT - REAL betacf,a,b,x,EPS,FPMIN - PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) - INTEGER m,m2 - REAL aa,c,d,del,h,qab,qam,qap - - qab=a+b - qap=a+1. - qam=a-1. - c=1. - d=1.-qab*x/qap - - if(abs(d).lt.FPMIN)d=FPMIN - d=1./d - h=d - do m=1,MAXIT - m2=2*m - aa=m*(b-m)*x/((qam+m2)*(a+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - h=h*d*c - aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - del=d*c - h=h*del - if(abs(del-1.).lt.EPS)exit - enddo - betacf=h - return - - END FUNCTION betacf +! Commented out functions betai(), betacf(), and gammln(). +! These functions are not used and were reproduced identically in +! GEOS_CatchCNCLM40GridComp.F90 and in GEOS_CatchCNCLM45GridComp.F90. +! Another copy was in GEOScatchCN_GridComp/utils/math_routines.F90 but +! there function betai() was missing the restriction 0.0125 0.9875) x = 0.9875 +!! +!! if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x +!! if(x.lt.0..or.x.gt.1.)stop +!! if(x.eq.0..or.x.eq.1.)then +!! bt=0. +!! else +!! bt=exp(gammln(a+b)-gammln(a)-gammln(b) & +!! +a*log(x)+b*log(1.-x)) +!! endif +!! +!! if(x.lt.(a+1.)/(a+b+2.))then +!! betai=bt*betacf(a,b,x)/a +!! return +!! else +!! betai=1.-bt*betacf(b,a,1.-x)/b +!! return +!! endif +!! +!! END FUNCTION betai +!! +!! ! ------------------------------------------------------- +!! +!! FUNCTION betacf(a,b,x) +!! +!! INTEGER MAXIT +!! REAL betacf,a,b,x,EPS,FPMIN +!! PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) +!! INTEGER m,m2 +!! REAL aa,c,d,del,h,qab,qam,qap +!! +!! qab=a+b +!! qap=a+1. +!! qam=a-1. +!! c=1. +!! d=1.-qab*x/qap +!! +!! if(abs(d).lt.FPMIN)d=FPMIN +!! d=1./d +!! h=d +!! do m=1,MAXIT +!! m2=2*m +!! aa=m*(b-m)*x/((qam+m2)*(a+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! h=h*d*c +!! aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! del=d*c +!! h=h*del +!! if(abs(del-1.).lt.EPS)exit +!! enddo +!! betacf=h +!! return +!! +!! END FUNCTION betacf +!! +!! ! -------------------------------------------------------------- +!! +!! FUNCTION gammln(xx) +!! +!! REAL gammln,xx +!! INTEGER j +!! DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) +!! +!! SAVE cof,stp +!! DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & +!! 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & +!! -.5395239384953d-5,2.5066282746310005d0/ +!! x=xx +!! y=x +!! tmp=x+5.5d0 +!! tmp=(x+0.5d0)*log(tmp)-tmp +!! ser=1.000000000190015d0 +!! do j=1,6 +!! y=y+1.d0 +!! ser=ser+cof(j)/y +!! enddo +!! gammln=tmp+log(stp*ser/x) +!! return +!! +!! END FUNCTION gammln ! -------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 deleted file mode 100755 index 88a6ee604..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 +++ /dev/null @@ -1,1186 +0,0 @@ -MODULE math_routines - -implicit none -private -public :: gammln, betai, betacf, rsq, prob_den_func, nbins, & - N_RANDOM_YEARS, shuffle, OPTIMIZ, N_PARAMS !,init_MPI -real, save :: U(97), CS, CD, CM -integer, save :: I97, J97 -integer, parameter :: N_PARAMS=3 -integer, parameter :: nbins = 40, N_RANDOM_YEARS = 41 - -! initialize to non-MPI values - include 'mpif.h' -!integer,public :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) -!logical, public :: root_proc=.true. - -contains - -! -! ---------------------------------------------------------------- -! - -subroutine Shuffle(a) - integer, intent(inout) :: a(:) - integer :: i, randpos, temp - real :: r - - call init_random_seed () - - do i = size(a), 2, -1 - call random_number(r) - randpos = int(r * i) + 1 - temp = a(randpos) - a(randpos) = a(i) - a(i) = temp - end do - end subroutine Shuffle - -! -! ------------------------------------------- -! - - SUBROUTINE init_random_seed() - INTEGER :: i, n, clock - INTEGER, DIMENSION(:), ALLOCATABLE :: seed - - CALL RANDOM_SEED(size = n) - ALLOCATE(seed(n)) - - CALL SYSTEM_CLOCK(COUNT=clock) - - seed = clock + 37 * (/ (i - 1, i = 1, n) /) - CALL RANDOM_SEED(PUT = seed) - - DEALLOCATE(seed) - -END SUBROUTINE init_random_seed - -! -! --------------------------------------------------------------------- -! - - SUBROUTINE random_rain(eta) - -!====================================================================== -! NPAC $Id: math_routines.F90,v 1.1 2018/05/10 15:05:29 smahanam Exp $ -!====================================================================== -! _____________________________________________________________________ -! | -! Test program to generate a vector of Gaussian deviates using | -! the Box-Muller method and the system-supplied uniform RNG. | -! K.A.Hawick, 15 July 1994. | -! | -! H W Yau. 23rd of August, 1996. | -! Northeast Parallel Architectures Center. | -! Syracuse University. | -!_____________________________________________________________________| -! | -! Edit record: | -! --/Jul/1996: M.McMahon -- ALIGN statement and EXTRINSIC statements | -! PROCESSORS statement as well. | -! 23/Aug/1996: HWY. Cleaning up. | -! Removed superfluous definition of module. | -! 26/Aug/1996: Added `IMPLICIT NONE'. | -! Fixed HPF directives. Cleaned up interface block to | -! gaussian_vector(). | -! F90 version. | -!_____________________________________________________________________| -! - - IMPLICIT NONE - - INTEGER, PARAMETER :: n = N_RANDOM_YEARS - REAL ti, tf,tcalc,tcom,tend,start - REAL, DIMENSION(1:n) :: a - REAL, DIMENSION(1:N)::ETA -! -! The vector of Guassian deviates - INTEGER, DIMENSION(1:n) :: j -! -! Histograms to check the distribution - INTEGER, DIMENSION(1:nbins) :: bins - INTEGER i,less, more,nb - INTEGER :: nover = 0 -! -! INTERFACE -! SUBROUTINE timer(return_time, initial_time) -! REAL, INTENT(IN) :: initial_time -! REAL, INTENT(OUT) :: return_time -! END SUBROUTINE -! END INTERFACE -! -! INTERFACE -! SUBROUTINE gaussian_vector(x,n,tcalc2,tcomm2) -! REAL, DIMENSION(:) :: x -! REAL,INTENT(INOUT) :: tcalc2,tcomm2 -! INTEGER,INTENT(IN) :: n -! REAL ETA -! END SUBROUTINE gaussian_vector -! END INTERFACE -!______________________________________________________________________ -! -! Executable Code. -!______________________________________________________________________ -! -! start_timer - CALL timer(start,0.0) - tcom = 0.0 - tcalc = 0.0 - CALL timer(ti,0.0) - bins(1:nbins) = 0 - CALL timer(tend,ti) - tcalc = tcalc + tend -! -! Ask for n deviate - CALL gaussian_vector( a, n,tend,tcom ) - tcalc = tcalc + tend - CALL timer(ti,0.0) -!F95 FORALL(i=1:n)j(i) = a(i) * real(nbins/7) + nbins/2 + 1 - DO i=1,n - j(i) = a(i) * real(nbins/7) + nbins/2 + 1 - END DO - CALL timer(tend,ti) - tcalc = tcalc + tend -! - CALL timer(ti,0.0) - DO i=1,n - ETA(I)=(REAL(J(I))-10.-1.)/5. - ENDDO -! write(*,*)eta -! write(*,*)sum(j)/300. - DO nb = 1,nbins - bins(nb) = count(j.EQ.nb,1) -!CCCCCCCC write(6,*) nb, bins(nb) - ENDDO - CALL timer(tend,ti) - tcom = tcom + tend -! -! Stop timer. - CALL timer(tf,start) -! -! Correction for serial execution. - tcalc = tcalc + tcom - tcom = 0.0 -! WRITE(6,6001) 0,n, -! 1 tcom,tcalc,(tf-tcom-tcalc),tf -! -! Write histogram - DO nb=1,nbins -! WRITE(6,*) nb,(REAL(NB)-10.-1.)/5., bins(nb) - ENDDO -! -! STOP - RETURN -! - 6001 FORMAT('Number of Processors = ',I4/ & - 'Problem size = ',I6/ & - 'Communications = ',F9.3/ & - 'Compute = ',F9.3/ & - 'Others = ',F9.3/ & - 'Total time = ',F9.3) -! - END SUBROUTINE random_rain -! -! ------------------------------------------------------ -! - - SUBROUTINE gaussian_vector( x, n, tcalc2,tcomm2 ) - - IMPLICIT NONE - ! - ! Box-Muller Method - ! See Knuth, Vol 2, 2nd Edn, PP 117 - INTEGER,INTENT(IN) :: n - REAL, DIMENSION(:) :: x - REAL,INTENT(INOUT) :: tcalc2,tcomm2 - REAL, DIMENSION(:), ALLOCATABLE :: v1, v2, r, f - REAL ti,cal1,cal2,com1,com2 - LOGICAL, DIMENSION(:), ALLOCATABLE :: mask - ! - ! Accept/reject efficiency is about 1.27 - integer m, i, np - !______________________________________________________________________ - ! - ! Executable code. - !______________________________________________________________________ - ! - CALL timer(ti,0.0) - np = n - ! - ! avoid fluctuation problems - IF( np .lt. 10 ) np = 10 - ALLOCATE( v1(np), v2(np), r(np), f(np), mask(np) ) - ! - ! Generate two deviates: - CALL random_number( v1 ) - CALL random_number( v2 ) - v1 = 2.0 * v1 -1.0 - v2 = 2.0 * v2 -1.0 - r = v1**2 + v2**2 - ! - ! are they in the unit circle? - mask = r < 1.0 - r = merge( r, 0.5, mask ) - f = sqrt( -2.0 * log(r) / r) - v1 = v1 * f - v2 = v2 * f - ! - ! since pack is a new intrinsic, here is serial code to show - ! what is being done. - ! m = 0 - ! do i=1,np - ! if( mask(i) )then - ! m = m + 1 - ! r(m) = v1(i) - ! f(m) = v2(i) - ! endif - ! enddo - CALL timer(cal1,ti) - - CALL timer(ti,0.0) - ! - ! we now have 2 * m deviates - m = count( mask ) - CALL timer(com1,ti) - - CALL timer(ti,0.0) - ! - ! and to save space, we'll store them in r and f - ! r = pack( v1, mask ) - ! f = pack( v2, mask ) - ! - ! We now get performance at the expense of memory. - r = v1 - f = v2 - ! - ! Statistically, this should not happen for large n - IF( 2*m .lt. n )THEN - WRITE(6,*) 'Not enough deviates! Got: ', 2*m, ', Needed: ', n - ! WRITE(6,*) 'Increase accept reject allowance in', - ! ' xgaussian_vector' - STOP - ENDIF - ! - ! use the two result vectors to patch up enough as - IF( m .LT. n )THEN - x(1:m)=r(1:m) - CALL timer(cal2,ti) - CALL timer(ti,0.0) - x(m+1:n) = f(1:n-m) - CALL timer(com2,ti) - ELSE - x(1:n) = r(1:n) - ENDIF - - tcalc2 = cal1 + cal2 - tcomm2 = com1 + com2 - DEALLOCATE( v1, v2, r, f, mask ) - - RETURN - END SUBROUTINE gaussian_vector -! -! ------------------------------------------------------------------- -! - SUBROUTINE timer(return_time, initial_time) - implicit none - REAL, INTENT(IN) :: initial_time - REAL, INTENT(OUT) :: return_time - INTEGER finish,rate - CALL system_clock( COUNT=finish,COUNT_RATE=rate) - return_time = FLOAT(finish) / FLOAT(rate) - initial_time - RETURN - END SUBROUTINE timer -! -! ------------------------------------------------------------------- -! - -subroutine prob_den_func (ndata, datain, cdf, bins, & - mean, std, skew, pdf, lwval, upval) - -implicit none -integer, intent (in) :: ndata -real, dimension(ndata), intent (in) :: datain -real, intent(out), dimension(nbins) :: cdf, bins -real, optional, intent(out), dimension(nbins) :: pdf -real, optional, intent (out) :: mean, std, skew -real, optional :: lwval, upval -real :: lw,up,db,var1,var2, variance -integer :: i,n - -lw = minval (datain) -up = maxval (datain) - -if(present(upval)) then - up = upval - lw = lwval -endif - -db = (up - lw)/real(nbins) -cdf = 0. -if(present(pdf)) pdf =0. - -do n = 1, nbins - bins (n) = lw + real(n)*db - db/2. - do i = 1,ndata - if(datain(i) <= bins (n) + db/2.) cdf(n) = cdf(n) + 1. - if(present(pdf)) then - if(n==1) then - if((datain(i) >= bins (n) - db/2.).and. & - (datain(i) <= bins (n) + db/2.)) & - pdf(n) = pdf(n) + 1. - else - if((datain(i) > bins (n) - db/2.).and. & - (datain(i) <= bins (n) + db/2.)) & - pdf(n) = pdf(n) + 1. - endif - endif - end do -end do - -cdf = cdf/real(ndata) - -if(present(pdf)) pdf = pdf/real(ndata) - -if(present (mean)) mean = sum(datain)/real(ndata) - -if(present (std)) then - - var1 = 0. - mean = sum(datain)/real(ndata) - - do i = 1,ndata - var1 = var1 + (datain(i) - mean)*(datain(i) - mean) - end do - - std = sqrt (var1/real(ndata - 1)) - - if(present (skew)) then - var2 = 0. - do i = 1,ndata - var2 = var2 + ((datain(i) - mean)/std)* & - ((datain(i) - mean)/std)* & - ((datain(i) - mean)/std) - end do - - skew = var2/real(ndata - 1) - - endif - -endif - -END subroutine prob_den_func - -! -! ------------------------------------------------------- -! - -FUNCTION betai(a,b,x) -REAL betai,a,b,x -REAL bt -!external gammln - -if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x -if(x.lt.0..or.x.gt.1.)stop -if(x.eq.0..or.x.eq.1.)then - bt=0. -else - bt=exp(gammln(a+b)-gammln(a)-gammln(b) & - +a*log(x)+b*log(1.-x)) -endif - -if(x.lt.(a+1.)/(a+b+2.))then - betai=bt*betacf(a,b,x)/a - return -else - betai=1.-bt*betacf(b,a,1.-x)/b - return -endif -END FUNCTION betai -! -! ------------------------------------------------------- -! -FUNCTION betacf(a,b,x) -INTEGER MAXIT -REAL betacf,a,b,x,EPS,FPMIN -PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) -INTEGER m,m2 -REAL aa,c,d,del,h,qab,qam,qap - -qab=a+b -qap=a+1. -qam=a-1. -c=1. -d=1.-qab*x/qap - -if(abs(d).lt.FPMIN)d=FPMIN -d=1./d -h=d -do m=1,MAXIT - m2=2*m - aa=m*(b-m)*x/((qam+m2)*(a+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - h=h*d*c - aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - del=d*c - h=h*del - if(abs(del-1.).lt.EPS)exit -enddo - betacf=h -return -END FUNCTION betacf -! -! -------------------------------------------------------------- -! -FUNCTION gammln(xx) -REAL gammln,xx -INTEGER j -DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) - -SAVE cof,stp -DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & - 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & - -.5395239384953d-5,2.5066282746310005d0/ -x=xx -y=x -tmp=x+5.5d0 -tmp=(x+0.5d0)*log(tmp)-tmp -ser=1.000000000190015d0 -do j=1,6 - y=y+1.d0 - ser=ser+cof(j)/y -enddo -gammln=tmp+log(stp*ser/x) -return -END FUNCTION gammln - -! -! ------------------------------------------------ -! - -SUBROUTINE RSQ (NDATA, X, Y, R2, RMSE, limits, slope, intercept) - -implicit none -integer, intent (in) :: NDATA -real, dimension (ndata), intent(in) :: x,y -real, optional, dimension(4), intent (in) :: limits -real, optional, intent(out) :: slope, intercept, RMSE -real, intent(out) :: r2 - -integer ::n -real :: ic -real :: sumx, sumy,sumxy, sumx2,sumy2,sig2x,sig2y,sig2xy,error - -ic =0. -sumx=0. -sumy=0. -sumxy=0. -sumy2=0. -sumx2=0. -error=0. -do n = 1,ndata - - if(present (limits)) then - if((x(n) > limits(1)).and.(x(n) < limits(2)).and. & - (y(n) > limits(3)).and.(y(n) < limits(4))) then - ic = ic + 1. - sumx = sumx + x(n) - sumy = sumy + y(n) - sumxy= sumxy + x(n)*y(n) - sumy2= sumy2 + y(n)*y(n) - sumx2= sumx2 + x(n)*x(n) - error= error + (y(n) - x(n))*(y(n) - x(n)) - endif - else - ic = ic + 1. - sumx = sumx + x(n) - sumy = sumy + y(n) - sumxy= sumxy + x(n)*y(n) - sumy2= sumy2 + y(n)*y(n) - sumx2= sumx2 + x(n)*x(n) - error= error + (y(n) - x(n))*(y(n) - x(n)) - endif - -end do - -if (present(intercept)) intercept = -9999. -if (present(slope)) slope = -9999. -if (present(rmse)) rmse = -9999. -r2 = -9999. - -if(ic /= 0) then - if(ic*sumx2 /= sumx*sumx) then - - if (present(intercept)) intercept = & - (sumy*sumx2 - sumx*sumxy) / (ic*sumx2 - sumx*sumx) - if (present(slope)) slope = & - (ic*sumxy - sumx*sumy) / (ic*sumx2 - sumx*sumx) - if (present(rmse)) rmse = sqrt(error/real(ic)) - endif - - sumx =sumx/ic - sumy =sumy/ic - sumxy=sumxy/ic - sumy2=sumy2/ic - sumx2=sumx2/ic - sig2x=sumx2-sumx*sumx - sig2y=sumy2-sumy*sumy - sig2xy=(sumxy-sumx*sumy)*(sumxy-sumx*sumy) - - r2 = sig2xy/(sig2x*sig2y + 1.e-20) -endif - -END SUBROUTINE RSQ - -! -! ------------------------------------------ -! - SUBROUTINE OPTIMIZ(NDATA,wet,eff,X) - - implicit none - - integer, PARAMETER :: N = N_PARAMS, NEPS = 4 - integer, intent (in) :: ndata - REAL (kind = 8) :: LB(N), UB(N), X(N), XOPT(N), CON(N), VM(N), & - FSTAR(NEPS), XP(N), T, EPS, RT, FOPT, & - EFF(NDATA),WET(NDATA) - - INTEGER NACP(N), NS, NT, NFCNEV, IER, ISEED1, ISEED2, & - MAXEVL, IPRINT, NACC, NOBDS, I - - LOGICAL MAX - -! Set underflows to zero on IBM mainframes. -! CALL XUFLOW(0) - - MAX = .false. - EPS = 1.0D-6 - RT = .5 - ISEED1 = 1 - ISEED2 = 2 - NS = 20 - NT = 5 - MAXEVL = 100000 - IPRINT = 0 - - DO I=1,N - LB(I)=0.0001 - UB(I)=100. - CON(I) = 2.0 - END DO - UB(3)= 1. - LB(3)= 0.1 -! -! Set input values of the input/output parameters. -! - T = 5.0 - DO I = 1, N - VM(I) = 1.0 - END DO - -! WRITE(*,1000) N, MAX, T, RT, EPS, NS, NT, NEPS, MAXEVL, IPRINT, & -! ISEED1, ISEED2 -! -! CALL PRTVEC(X,N,'STARTING VALUES') -! CALL PRTVEC(VM,N,'INITIAL STEP LENGTH') -! CALL PRTVEC(LB,N,'LOWER BOUND') -! CALL PRTVEC(UB,N,'UPPER BOUND') -! CALL PRTVEC(C,N,'C VECTOR') -! WRITE(*,'(/,'' **** END OF DRIVER ROUTINE OUTPUT ****'' & -! /,'' **** BEFORE CALL TO SA. ****'')') - - CALL SA(X,MAX,RT,EPS,NS,NT,NEPS,MAXEVL,LB,UB,CON,IPRINT,ISEED1, & - ISEED2,T,VM,XOPT,FOPT,NACC,NFCNEV,NOBDS,IER, & - FSTAR,XP,NACP,NDATA,EFF,WET) - -! WRITE(*,'(/,'' **** RESULTS AFTER SA **** '')') -! CALL PRTVEC(XOPT,N,'SOLUTION') -! CALL PRTVEC(VM,N,'FINAL STEP LENGTH') -! WRITE(*,1001) FOPT, NFCNEV, NACC, NOBDS, T, IER - -1000 FORMAT(/,' SIMULATED ANNEALING EXAMPLE',/, & - /,' NUMBER OF PARAMETERS: ',I3,' MAXIMAZATION: ',L5, & - /,' INITIAL TEMP: ', G8.2, ' RT: ',G8.2, ' EPS: ',G8.2, & - /,' NS: ',I3, ' NT: ',I2, ' NEPS: ',I2, & - /,' MAXEVL: ',I10, ' IPRINT: ',I1, ' ISEED1: ',I4, & - ' ISEED2: ',I4) -1001 FORMAT(/,' OPTIMAL FUNCTION VALUE: ',G20.13 & - /,' NUMBER OF FUNCTION EVALUATIONS: ',I10, & - /,' NUMBER OF ACCEPTED EVALUATIONS: ',I10, & - /,' NUMBER OF OUT OF BOUND EVALUATIONS: ',I10, & - /,' FINAL TEMP: ', G20.13,' IER: ', I3) - - RETURN - END SUBROUTINE OPTIMIZ - -! -! --------------------------------------------------------------- -! - - SUBROUTINE SA(X,MAX,RT,EPS,NS,NT,NEPS,MAXEVL,LB,UB,CON,IPRINT, & - ISEED1,ISEED2,T,VM,XOPT,FOPT,NACC,NFCNEV,NOBDS,IER, & - FSTAR,XP,NACP,NDATA,EFF,WET) - -! Type all external variables. - - INTEGER,PARAMETER :: N=N_PARAMS - integer :: ndata - REAL (KIND = 8) X(N), LB(N), UB(N), CON(N), VM(N), FSTAR(N), & - XOPT(N), XP(N), T, EPS, RT, FOPT - REAL (KIND = 8) EFF(NDATA),WET(NDATA) - INTEGER NACP(N), NS, NT, NEPS, NACC, MAXEVL, IPRINT, & - NOBDS, IER, NFCNEV, ISEED1, ISEED2 - LOGICAL MAX - -! Type all internal variables. - REAL (KIND = 8) F, FP, P, PP, RATIO - INTEGER NUP, NDOWN, NREJ, NNEW, LNOBDS, H, I, J, M - LOGICAL QUIT - -! Type all functions. -! REAL (KIND = 8) EXPREP - -! Initialize the random number generator RANMAR. - CALL RMARIN(ISEED1,ISEED2) - -! Set initial values. - NACC = 0 - NOBDS = 0 - NFCNEV = 0 - IER = 99 - - DO I = 1, N - XOPT(I) = X(I) - NACP(I) = 0 - END DO - - DO I = 1, NEPS - FSTAR(I) = 1.0D+20 - END DO - -! If the initial temperature is not positive, notify the user and -! return to the calling routine. - IF (T .LE. 0.0) THEN - WRITE(*,'(/,'' THE INITIAL TEMPERATURE IS NOT POSITIVE. '' & - /,'' RESET THE VARIABLE T. ''/)') - IER = 3 - RETURN - END IF - -! If the initial value is out of bounds, notify the user and return -! to the calling routine. - DO I = 1, N - IF ((X(I) .GT. UB(I)) .OR. (X(I) .LT. LB(I))) THEN - CALL PRT1 - IER = 2 - RETURN - END IF - END DO - -! Evaluate the function with input X and return value as F. - CALL FCN(X,F,NDATA,EFF,WET) - -! If the function is to be minimized, switch the sign of the function. -! Note that all intermediate and final output switches the sign back -! to eliminate any possible confusion for the user. - IF(.NOT. MAX) F = -F - NFCNEV = NFCNEV + 1 - FOPT = F - FSTAR(1) = F - IF(IPRINT .GE. 1) CALL PRT2(MAX,N,X,F) - -! Start the main loop. Note that it terminates if (i) the algorithm -! succesfully optimizes the function or (ii) there are too many -! function evaluations (more than MAXEVL). -100 NUP = 0 - NREJ = 0 - NNEW = 0 - NDOWN = 0 - LNOBDS = 0 - - DO M = 1, NT - DO J = 1, NS - DO H = 1, N - -! Generate XP, the trial value of X. Note use of VM to choose XP. - DO I = 1, N - IF (I .EQ. H) THEN - XP(I) = X(I) + (RANMAR()*2.- 1.) * VM(I) - ELSE - XP(I) = X(I) - END IF - -! If XP is out of bounds, select a point in bounds for the trial. - IF((XP(I) .LT. LB(I)) .OR. (XP(I) .GT. UB(I))) THEN - XP(I) = LB(I) + (UB(I) - LB(I))*RANMAR() - LNOBDS = LNOBDS + 1 - NOBDS = NOBDS + 1 - IF(IPRINT .GE. 3) CALL PRT3(MAX,N,XP,X,FP,F) - END IF - END DO -! Evaluate the function with the trial point XP and return as FP. - CALL FCN(XP,FP,NDATA,EFF,WET) - IF(.NOT. MAX) FP = -FP - NFCNEV = NFCNEV + 1 - IF(IPRINT .GE. 3) CALL PRT4(MAX,N,XP,X,FP,F) - -! If too many function evaluations occur, terminate the algorithm. - IF(NFCNEV .GE. MAXEVL) THEN - CALL PRT5 - IF (.NOT. MAX) FOPT = -FOPT - IER = 1 - RETURN - END IF - -! Accept the new point if the function value increases. - IF(FP .GE. F) THEN - IF(IPRINT .GE. 3) THEN - WRITE(*,'('' POINT ACCEPTED'')') - END IF - DO I = 1, N - X(I) = XP(I) - END DO - F = FP - NACC = NACC + 1 - NACP(H) = NACP(H) + 1 - NUP = NUP + 1 - -! If greater than any other point, record as new optimum. - IF (FP .GT. FOPT) THEN - IF(IPRINT .GE. 3) THEN - WRITE(*,'('' NEW OPTIMUM'')') - END IF - DO I = 1, N - XOPT(I) = XP(I) - END DO - FOPT = FP - NNEW = NNEW + 1 - END IF - - ! If the point is lower, use the Metropolis criteria to decide on - ! acceptance or rejection. - ELSE - P = EXPREP((FP - F)/T) - PP = RANMAR() - IF (PP .LT. P) THEN - IF(IPRINT .GE. 3) CALL PRT6(MAX) - DO I = 1, N - X(I) = XP(I) - END DO - F = FP - NACC = NACC + 1 - NACP(H) = NACP(H) + 1 - NDOWN = NDOWN + 1 - ELSE - NREJ = NREJ + 1 - IF(IPRINT .GE. 3) CALL PRT7(MAX) - END IF - END IF - - END DO - END DO - -! Adjust VM so that approximately half of all evaluations are accepted. - DO I = 1, N - RATIO = DFLOAT(NACP(I)) /DFLOAT(NS) - IF (RATIO .GT. .6) THEN - VM(I) = VM(I)*(1. + CON(I)*(RATIO - .6)/.4) - ELSE IF (RATIO .LT. .4) THEN - VM(I) = VM(I)/(1. + CON(I)*((.4 - RATIO)/.4)) - END IF - IF (VM(I) .GT. (UB(I)-LB(I))) THEN - VM(I) = UB(I) - LB(I) - END IF - END DO - - IF(IPRINT .GE. 2) THEN - CALL PRT8(N,VM,XOPT,X) - END IF - - DO I = 1, N - NACP(I) = 0 - END DO - - END DO - - IF(IPRINT .GE. 1) THEN - CALL PRT9(MAX,N,T,XOPT,VM,FOPT,NUP,NDOWN,NREJ,LNOBDS,NNEW) - END IF - -! Check termination criteria. - QUIT = .FALSE. - FSTAR(1) = F - IF ((FOPT - FSTAR(1)) .LE. EPS) QUIT = .TRUE. - DO I = 1, NEPS - IF (ABS(F - FSTAR(I)) .GT. EPS) QUIT = .FALSE. - END DO - -! Terminate SA if appropriate. - IF (QUIT) THEN - DO I = 1, N - X(I) = XOPT(I) - END DO - IER = 0 - IF (.NOT. MAX) FOPT = -FOPT - IF(IPRINT .GE. 1) CALL PRT10 - RETURN - END IF - -! If termination criteria is not met, prepare for another loop. - T = RT*T - DO I = NEPS, 2, -1 - FSTAR(I) = FSTAR(I-1) - END DO - F = FOPT - DO I = 1, N - X(I) = XOPT(I) - END DO - -! Loop again. - GO TO 100 - - END SUBROUTINE SA -! -! --------------------------------------------------------- -! - - SUBROUTINE FCN(X,F,NDATA,EFF,WET) - implicit none - integer, parameter :: N = N_PARAMS - REAL (KIND = 8) X(n),F - INTEGER, intent (in) :: ndata - INTEGER Nd - REAL (KIND = 8) EFF(NDATA),WET(NDATA) - real :: a,b,xv, r2, rmse - real , dimension(ndata) :: yval, xval - - a = X(1) - b = X(2) - - do nd = 1, ndata - xv = wet(nd) - xval(nd) = eff(nd) - yval(nd) = X(3)*betai(a,b,xv) - end do - -! if(maxval(yval) > 1.) print *,maxval(yval), minval(yval) - - call rsq (ndata, xval, yval, r2, rmse) - F = rmse -! if(maxval(yval) > 1.) F = 1.d10 -! F = r2 -! if(F > 1.) F = -1.d-10 - - RETURN - END SUBROUTINE FCN - -! -! --------------------------------------------------------------- -! - FUNCTION EXPREP(RDUM) - implicit none - REAL (KIND = 8) RDUM, EXPREP - - IF (RDUM .GT. 174.) THEN - EXPREP = 3.69D+75 - ELSE IF (RDUM .LT. -180.) THEN - EXPREP = 0.0 - ELSE - EXPREP = EXP(RDUM) - END IF - - RETURN - END FUNCTION EXPREP -! -! --------------------------------------------- -! - subroutine RMARIN(IJ,KL) - - implicit none - integer, intent (in) :: ij,kl - integer :: i,j,k,l,m, ii,jj - real :: t,s - -! real U(97), C, CD, CM -! integer I97, J97 -! common /raset1/ U, C, CD, CM, I97, J97 - - if( IJ .lt. 0 .or. IJ .gt. 31328 .or. & - KL .lt. 0 .or. KL .gt. 30081 ) then - print '(A)', ' The first random number seed must have a value between 0 and 31328' - print '(A)',' The second seed must have a value between 0 and 30081' - stop - endif - - i = mod(IJ/177, 177) + 2 - j = mod(IJ , 177) + 2 - k = mod(KL/169, 178) + 1 - l = mod(KL, 169) - - do ii = 1, 97 - s = 0.0 - t = 0.5 - do jj = 1, 24 - m = mod(mod(i*j, 179)*k, 179) - i = j - j = k - k = m - l = mod(53*l+1, 169) - if (mod(l*m, 64) .ge. 32) then - s = s + t - endif - t = 0.5 * t - end do - U(ii) = s - end do - - - CS = 362436.0 / 16777216.0 - CD = 7654321.0 / 16777216.0 - CM = 16777213.0 /16777216.0 - I97 = 97 - J97 = 33 - return - end subroutine RMARIN - -! -! --------------------------------------- -! - - real function ranmar() - real :: uni -! real U(97), C, CD, CM -! integer I97, J97 -! common /raset1/ U, C, CD, CM, I97, J97 - uni = U(I97) - U(J97) - if( uni .lt. 0.0 ) uni = uni + 1.0 - U(I97) = uni - I97 = I97 - 1 - if(I97 .eq. 0) I97 = 97 - J97 = J97 - 1 - if(J97 .eq. 0) J97 = 97 - CS = CS - CD - if( CS .lt. 0.0 ) CS = CS + CM - uni = uni - CS - if( uni .lt. 0.0 ) uni = uni + 1.0 - RANMAR = uni - return - END function ranmar - - SUBROUTINE PRT1 - implicit none - WRITE(*,'(/,'' THE STARTING VALUE (X) IS OUTSIDE THE BOUNDS '' & - /,'' (LB AND UB). EXECUTION TERMINATED WITHOUT ANY'' & - /,'' OPTIMIZATION. RESPECIFY X, UB OR LB SO THAT '' & - /,'' LB(I) .LT. X(I) .LT. UB(I), I = 1, N. ''/)') - - RETURN - END SUBROUTINE PRT1 - - SUBROUTINE PRT2(MAX,N,X,F) - implicit none - REAL (KIND = 8) X(N), F - INTEGER N - LOGICAL MAX - - WRITE(*,'('' '')') - CALL PRTVEC(X,N,'INITIAL X') - IF (MAX) THEN - WRITE(*,'('' INITIAL F: '',/, G25.18)') F - ELSE - WRITE(*,'('' INITIAL F: '',/, G25.18)') -F - END IF - - RETURN - END SUBROUTINE PRT2 - - SUBROUTINE PRT3(MAX,N,XP,X,FP,F) - implicit none - REAL (KIND = 8) XP(N), X(N), FP, F - INTEGER N - LOGICAL MAX - - WRITE(*,'('' '')') - CALL PRTVEC(X,N,'CURRENT X') - IF (MAX) THEN - WRITE(*,'('' CURRENT F: '',G25.18)') F - ELSE - WRITE(*,'('' CURRENT F: '',G25.18)') -F - END IF - CALL PRTVEC(XP,N,'TRIAL X') - WRITE(*,'('' POINT REJECTED SINCE OUT OF BOUNDS'')') - - RETURN - END SUBROUTINE PRT3 - - SUBROUTINE PRT4(MAX,N,XP,X,FP,F) - implicit none - REAL (KIND = 8) XP(N), X(N), FP, F - INTEGER N - LOGICAL MAX - - WRITE(*,'('' '')') - CALL PRTVEC(X,N,'CURRENT X') - IF (MAX) THEN - WRITE(*,'('' CURRENT F: '',G25.18)') F - CALL PRTVEC(XP,N,'TRIAL X') - WRITE(*,'('' RESULTING F: '',G25.18)') FP - ELSE - WRITE(*,'('' CURRENT F: '',G25.18)') -F - CALL PRTVEC(XP,N,'TRIAL X') - WRITE(*,'('' RESULTING F: '',G25.18)') -FP - END IF - - RETURN - END SUBROUTINE PRT4 - - SUBROUTINE PRT5 - implicit none - WRITE(*,'(/,'' TOO MANY FUNCTION EVALUATIONS; CONSIDER '' & - /,'' INCREASING MAXEVL OR EPS, OR DECREASING '' & - /,'' NT OR RT. THESE RESULTS ARE LIKELY TO BE '' & - /,'' POOR.'',/)') - - RETURN - END SUBROUTINE PRT5 - - SUBROUTINE PRT6(MAX) - implicit none - LOGICAL MAX - - IF (MAX) THEN - WRITE(*,'('' THOUGH LOWER, POINT ACCEPTED'')') - ELSE - WRITE(*,'('' THOUGH HIGHER, POINT ACCEPTED'')') - END IF - - RETURN - END SUBROUTINE PRT6 - - SUBROUTINE PRT7(MAX) - implicit none - LOGICAL MAX - - IF (MAX) THEN - WRITE(*,'('' LOWER POINT REJECTED'')') - ELSE - WRITE(*,'('' HIGHER POINT REJECTED'')') - END IF - - RETURN - END SUBROUTINE PRT7 - - SUBROUTINE PRT8(N,VM,XOPT,X) - implicit none - REAL (KIND = 8) VM(N), XOPT(N), X(N) - INTEGER N - - WRITE(*,'(/,'' INTERMEDIATE RESULTS AFTER STEP LENGTH ADJUSTMENT'',/)') - CALL PRTVEC(VM,N,'NEW STEP LENGTH (VM)') - CALL PRTVEC(XOPT,N,'CURRENT OPTIMAL X') - CALL PRTVEC(X,N,'CURRENT X') - WRITE(*,'('' '')') - - RETURN - END SUBROUTINE PRT8 - - SUBROUTINE PRT9(MAX,N,T,XOPT,VM,FOPT,NUP,NDOWN,NREJ,LNOBDS,NNEW) - implicit none - REAL (KIND = 8) XOPT(N), VM(N), T, FOPT - INTEGER N, NUP, NDOWN, NREJ, LNOBDS, NNEW, TOTMOV - LOGICAL MAX - - TOTMOV = NUP + NDOWN + NREJ - - WRITE(*,'(/, '' INTERMEDIATE RESULTS BEFORE NEXT TEMPERATURE REDUCTION'',/)') - WRITE(*,'('' CURRENT TEMPERATURE: '',G12.5)') T - IF (MAX) THEN - WRITE(*,'('' MAX FUNCTION VALUE SO FAR: '',G25.18)') FOPT - WRITE(*,'('' TOTAL MOVES: '',I8)') TOTMOV - WRITE(*,'('' UPHILL: '',I8)') NUP - WRITE(*,'('' ACCEPTED DOWNHILL: '',I8)') NDOWN - WRITE(*,'('' REJECTED DOWNHILL: '',I8)') NREJ - WRITE(*,'('' OUT OF BOUNDS TRIALS: '',I8)') LNOBDS - WRITE(*,'('' NEW MAXIMA THIS TEMPERATURE:'',I8)') NNEW - ELSE - WRITE(*,'('' MIN FUNCTION VALUE SO FAR: '',G25.18)') -FOPT - WRITE(*,'('' TOTAL MOVES: '',I8)') TOTMOV - WRITE(*,'('' DOWNHILL: '',I8)') NUP - WRITE(*,'('' ACCEPTED UPHILL: '',I8)') NDOWN - WRITE(*,'('' REJECTED UPHILL: '',I8)') NREJ - WRITE(*,'('' TRIALS OUT OF BOUNDS: '',I8)') LNOBDS - WRITE(*,'('' NEW MINIMA THIS TEMPERATURE:'',I8)') NNEW - END IF - CALL PRTVEC(XOPT,N,'CURRENT OPTIMAL X') - CALL PRTVEC(VM,N,'STEP LENGTH (VM)') - WRITE(*,'('' '')') - - RETURN - END SUBROUTINE PRT9 - - SUBROUTINE PRT10 - implicit none - WRITE(*,'(/,'' SA ACHIEVED TERMINATION CRITERIA. IER = 0. '',/)') - - RETURN - END SUBROUTINE PRT10 - - SUBROUTINE PRTVEC(VECTOR,NCOLS,NAME) - implicit none - INTEGER NCOLS, LL,I,J, LINES - REAL (KIND = 8) VECTOR(NCOLS) - CHARACTER *(*) NAME - - WRITE(*,1001) NAME - - IF (NCOLS .GT. 10) THEN - LINES = INT(NCOLS/10.) - - DO I = 1, LINES - LL = 10*(I - 1) - WRITE(*,1000) (VECTOR(J),J = 1+LL, 10+LL) - END DO - - WRITE(*,1000) (VECTOR(J),J = 11+LL, NCOLS) - ELSE - WRITE(*,1000) (VECTOR(J),J = 1, NCOLS) - END IF - -1000 FORMAT( 10(G12.5,1X)) -1001 FORMAT(/,25X,A) - - RETURN - - END SUBROUTINE PRTVEC - - ! ***************************************************************************** - ! - ! subroutine init_MPI() - ! - ! ! initialize MPI - ! - ! call MPI_INIT(mpierr) - ! - ! call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - ! call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - ! - ! if (myid .ne. 0) root_proc = .false. - ! -!! call init_MPI_types() - ! - ! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" - ! write (*,*) "MPI process ", myid, ": root_proc=", root_proc -! -! end subroutine init_MPI - - -END MODULE math_routines From f890c8c10976fcf00de35e4ca8ca13fd9a91c7dd Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Wed, 25 May 2022 13:05:07 -0400 Subject: [PATCH 18/21] fix warning messages in bcs/clsm/*_params.nc4 --- .../Utils/Raster/mkCatchParam.F90 | 14 ++++++++++---- .../Utils/Raster/mod_process_hres_data.F90 | 9 +++++---- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index b51606f51..6569a2951 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -59,6 +59,7 @@ PROGRAM mkCatchParam type (regrid_map) :: maparc30, mapgeoland2,maparc60 character*200 :: tmpstring, tmpstring1, tmpstring2 character*200 :: fname_tmp, fname_tmp2, fname_tmp3, fname_tmp4 + integer :: maxcat ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -213,9 +214,6 @@ PROGRAM mkCatchParam write (log_file,'(a)')'Cube-Sphere Grid - assuming dateline-on-edge (DE)' endif - inquire(file='clsm/catch_params.nc4', exist=file_exists) - if (.not.file_exists) CALL open_landparam_nc4_files - ! ****************************************************************************** ! ! IMPORTANT: The top-level make_bcs script should not allow this program to @@ -244,7 +242,15 @@ PROGRAM mkCatchParam write (log_file,'(a)')'Skipping step for EASE grid. ' endif write (log_file,'(a)')' ' - + + open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & + action = 'read') + read (10, *) maxcat + close (10, status = 'keep') + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + if (.not.file_exists) CALL open_landparam_nc4_files(maxcat) + ! Creating cti_stats.dat ! ---------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 65aa353ee..c0f976518 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -5846,11 +5846,12 @@ END SUBROUTINE gimms_clim_ndvi ! -------------------------------------------------------------------------- - SUBROUTINE open_landparam_nc4_files + SUBROUTINE open_landparam_nc4_files(maxcat) implicit none integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID integer :: STATUS, CellID1, CellID2, CellID3, SubID + integer, intent (in) :: maxcat integer, dimension(8) :: date_time_values character (22) :: time_stamp character (100) :: MYNAME @@ -5859,9 +5860,9 @@ SUBROUTINE open_landparam_nc4_files status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) - status = NF_DEF_DIM(NCCatOUTID , 'tile' , NF_UNLIMITED, CellID1) - status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , NF_UNLIMITED, CellID2) - status = NF_DEF_DIM(NCVegOUTID , 'tile' , NF_UNLIMITED, CellID3) + status = NF_DEF_DIM(NCCatOUTID , 'tile' , maxcat, CellID1) + status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , maxcat, CellID2) + status = NF_DEF_DIM(NCVegOUTID , 'tile' , maxcat, CellID3) status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) From d745c08b3014596c5b696e4a3c85d194008a270a Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Wed, 25 May 2022 18:02:53 -0400 Subject: [PATCH 19/21] rename maxcat to n_tile --- .../GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 | 6 +++--- .../Utils/Raster/mod_process_hres_data.F90 | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index 6569a2951..fe035a9e5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -59,7 +59,7 @@ PROGRAM mkCatchParam type (regrid_map) :: maparc30, mapgeoland2,maparc60 character*200 :: tmpstring, tmpstring1, tmpstring2 character*200 :: fname_tmp, fname_tmp2, fname_tmp3, fname_tmp4 - integer :: maxcat + integer :: N_tile ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -245,11 +245,11 @@ PROGRAM mkCatchParam open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & action = 'read') - read (10, *) maxcat + read (10, *) N_tile close (10, status = 'keep') inquire(file='clsm/catch_params.nc4', exist=file_exists) - if (.not.file_exists) CALL open_landparam_nc4_files(maxcat) + if (.not.file_exists) CALL open_landparam_nc4_files(N_tile) ! Creating cti_stats.dat ! ---------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index c0f976518..a75036635 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -5846,12 +5846,12 @@ END SUBROUTINE gimms_clim_ndvi ! -------------------------------------------------------------------------- - SUBROUTINE open_landparam_nc4_files(maxcat) + SUBROUTINE open_landparam_nc4_files(N_tile) implicit none integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID integer :: STATUS, CellID1, CellID2, CellID3, SubID - integer, intent (in) :: maxcat + integer, intent (in) :: N_tile integer, dimension(8) :: date_time_values character (22) :: time_stamp character (100) :: MYNAME @@ -5860,9 +5860,9 @@ SUBROUTINE open_landparam_nc4_files(maxcat) status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) - status = NF_DEF_DIM(NCCatOUTID , 'tile' , maxcat, CellID1) - status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , maxcat, CellID2) - status = NF_DEF_DIM(NCVegOUTID , 'tile' , maxcat, CellID3) + status = NF_DEF_DIM(NCCatOUTID , 'tile' , N_tile, CellID1) + status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , N_tile, CellID2) + status = NF_DEF_DIM(NCVegOUTID , 'tile' , N_tile, CellID3) status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) From 0ac161f131c4d23392c4f80addd01ea0bda060ac Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 3 Jun 2022 18:06:38 -0400 Subject: [PATCH 20/21] bug fix and clarification of water table depth and free-standing surface water output: - renamed WATERTABLED --> PEATCLSM_WATERLEVEL - renamed FSWCHANGE --> PEATCLSM_FSWCHANGE - restricted above exports to PEATCLSM tiles - flipped sign convention for PEATCLSM_WATERLEVEL --- .../GEOS_SurfaceGridComp.F90 | 38 +++++++-------- .../GEOSland_GridComp/GEOS_LandGridComp.F90 | 8 ++-- .../GEOS_CatchCNGridComp.F90 | 4 +- .../GEOS_CatchCNCLM40GridComp.F90 | 31 ++++++++----- .../GEOS_CatchCNCLM45GridComp.F90 | 31 ++++++++----- .../GEOScatch_GridComp/GEOS_CatchGridComp.F90 | 29 +++++++----- .../GEOSland_GridComp/Shared/lsm_routines.F90 | 46 +++++++++++++++---- 7 files changed, 119 insertions(+), 68 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 index d04378320..9b111edcf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 @@ -2732,9 +2732,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsHorzOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -2743,7 +2743,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsHorzOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -5125,8 +5125,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: RMELTBC002 => NULL() real, pointer, dimension(:,:) :: RMELTOC001 => NULL() real, pointer, dimension(:,:) :: RMELTOC002 => NULL() - real, pointer, dimension(:,:) :: WATERTABLED => NULL() - real, pointer, dimension(:,:) :: FSWCHANGE => NULL() + real, pointer, dimension(:,:) :: PEATCLSM_WATERLEVEL => NULL() + real, pointer, dimension(:,:) :: PEATCLSM_FSWCHANGE => NULL() ! CN model real, pointer, dimension(:,:) :: CNLAI => NULL() @@ -5386,8 +5386,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: RMELTBC002TILE => NULL() real, pointer, dimension(:) :: RMELTOC001TILE => NULL() real, pointer, dimension(:) :: RMELTOC002TILE => NULL() - real, pointer, dimension(:) :: WATERTABLEDTILE => NULL() - real, pointer, dimension(:) :: FSWCHANGETILE => NULL() + real, pointer, dimension(:) :: PEATCLSM_WATERLEVELTILE => NULL() + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGETILE => NULL() real, pointer, dimension(:) :: CNLAITILE => NULL() real, pointer, dimension(:) :: CNTLAITILE => NULL() @@ -6222,8 +6222,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT , RMELTBC002 , 'RMELTBC002', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , RMELTOC001 , 'RMELTOC001', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , RMELTOC002 , 'RMELTOC002', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT , WATERTABLED, 'WATERTABLED', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT , FSWCHANGE , 'FSWCHANGE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , PEATCLSM_WATERLEVEL, 'PEATCLSM_WATERLEVEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , PEATCLSM_FSWCHANGE, 'PEATCLSM_FSWCHANGE', RC=STATUS); VERIFY_(STATUS) IF(LSM_CHOICE > 1) THEN @@ -6798,8 +6798,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(RMELTBC002 ,RMELTBC002TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(RMELTOC001 ,RMELTOC001TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(RMELTOC002 ,RMELTOC002TILE ,NT,RC=STATUS); VERIFY_(STATUS) - call MKTILE(WATERTABLED,WATERTABLEDTILE,NT,RC=STATUS); VERIFY_(STATUS) - call MKTILE(FSWCHANGE ,FSWCHANGETILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(PEATCLSM_WATERLEVEL,PEATCLSM_WATERLEVELTILE,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(PEATCLSM_FSWCHANGE ,PEATCLSM_FSWCHANGETILE ,NT,RC=STATUS); VERIFY_(STATUS) IF (LSM_CHOICE > 1) THEN call MKTILE(CNLAI ,CNLAITILE ,NT,RC=STATUS); VERIFY_(STATUS) @@ -7644,8 +7644,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(RMELTBC002 ))call MAPL_LocStreamTransform(LOCSTREAM,RMELTBC002 ,RMELTBC002TILE, RC=STATUS); VERIFY_(STATUS) if(associated(RMELTOC001 ))call MAPL_LocStreamTransform(LOCSTREAM,RMELTOC001 ,RMELTOC001TILE, RC=STATUS); VERIFY_(STATUS) if(associated(RMELTOC002 ))call MAPL_LocStreamTransform(LOCSTREAM,RMELTOC002 ,RMELTOC002TILE, RC=STATUS); VERIFY_(STATUS) - if(associated(WATERTABLED))call MAPL_LocStreamTransform(LOCSTREAM,WATERTABLED,WATERTABLEDTILE,RC=STATUS); VERIFY_(STATUS) - if(associated(FSWCHANGE ))call MAPL_LocStreamTransform(LOCSTREAM,FSWCHANGE ,FSWCHANGETILE, RC=STATUS); VERIFY_(STATUS) + if(associated(PEATCLSM_WATERLEVEL))call MAPL_LocStreamTransform(LOCSTREAM,PEATCLSM_WATERLEVEL,PEATCLSM_WATERLEVELTILE,RC=STATUS); VERIFY_(STATUS) + if(associated(PEATCLSM_FSWCHANGE ))call MAPL_LocStreamTransform(LOCSTREAM,PEATCLSM_FSWCHANGE ,PEATCLSM_FSWCHANGETILE, RC=STATUS); VERIFY_(STATUS) if(associated(CNLAI)) then call MAPL_LocStreamTransform( LOCSTREAM,CNLAI ,CNLAITILE , RC=STATUS) @@ -8179,8 +8179,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(RMELTBC002TILE )) deallocate(RMELTBC002TILE ) if(associated(RMELTOC001TILE )) deallocate(RMELTOC001TILE ) if(associated(RMELTOC002TILE )) deallocate(RMELTOC002TILE ) - if(associated(WATERTABLEDTILE)) deallocate(WATERTABLEDTILE) - if(associated(FSWCHANGETILE )) deallocate(FSWCHANGETILE ) + if(associated(PEATCLSM_WATERLEVELTILE)) deallocate(PEATCLSM_WATERLEVELTILE) + if(associated(PEATCLSM_FSWCHANGETILE )) deallocate(PEATCLSM_FSWCHANGETILE ) if(associated(CNLAITILE )) deallocate(CNLAITILE ) if(associated(CNTLAITILE )) deallocate(CNTLAITILE ) if(associated(CNSAITILE )) deallocate(CNSAITILE ) @@ -8516,9 +8516,9 @@ subroutine DOTYPE(type,RC) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'RMELTOC002' , ALLOC=associated(RMELTOC002TILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(GEX(type), dum, 'WATERTABLED', ALLOC=associated(WATERTABLEDTILE ),notFoundOK=.true., RC=STATUS) + call MAPL_GetPointer(GEX(type), dum, 'PEATCLSM_WATERLEVEL', ALLOC=associated(PEATCLSM_WATERLEVELTILE), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(GEX(type), dum, 'FSWCHANGE' , ALLOC=associated(FSWCHANGETILE ) , notFoundOK=.true., RC=STATUS) + call MAPL_GetPointer(GEX(type), dum, 'PEATCLSM_FSWCHANGE' , ALLOC=associated(PEATCLSM_FSWCHANGETILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) IF (LSM_CHOICE > 1) THEN @@ -9088,8 +9088,8 @@ subroutine DOTYPE(type,RC) if(associated(RMELTBC002TILE)) call FILLOUT_TILE(GEX(type), 'RMELTBC002' , RMELTBC002TILE , XFORM, RC=STATUS);VERIFY_(STATUS) if(associated(RMELTOC001TILE)) call FILLOUT_TILE(GEX(type), 'RMELTOC001' , RMELTOC001TILE , XFORM, RC=STATUS);VERIFY_(STATUS) if(associated(RMELTOC002TILE)) call FILLOUT_TILE(GEX(type), 'RMELTOC002' , RMELTOC002TILE , XFORM, RC=STATUS);VERIFY_(STATUS) - if(associated(WATERTABLEDTILE))call FILLOUT_TILE(GEX(type), 'WATERTABLED', WATERTABLEDTILE, XFORM, RC=STATUS);VERIFY_(STATUS) - if(associated(FSWCHANGETILE)) call FILLOUT_TILE(GEX(type), 'FSWCHANGE' , FSWCHANGETILE , XFORM, RC=STATUS);VERIFY_(STATUS) + if(associated(PEATCLSM_WATERLEVELTILE)) call FILLOUT_TILE(GEX(type), 'PEATCLSM_WATERLEVEL', PEATCLSM_WATERLEVELTILE, XFORM, RC=STATUS);VERIFY_(STATUS) + if(associated(PEATCLSM_FSWCHANGETILE)) call FILLOUT_TILE(GEX(type), 'PEATCLSM_FSWCHANGE' , PEATCLSM_FSWCHANGETILE , XFORM, RC=STATUS);VERIFY_(STATUS) if(associated(CNLAITILE)) then call FILLOUT_TILE(GEX(type), 'CNLAI' , CNLAITILE , XFORM, RC=STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index bfca66893..e762166db 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -920,8 +920,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTBC002', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC001', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC002', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'WATERTABLED',CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'FSWCHANGE', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_WATERLEVEL',CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_FSWCHANGE', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) if (DO_GOSWIM /= 0) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RDU001', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) @@ -1292,8 +1292,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTBC002', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC001', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC002', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'WATERTABLED',CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'FSWCHANGE', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_WATERLEVEL',CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_FSWCHANGE', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) if (DO_GOSWIM /= 0) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RDU001', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 index e790bcd5f..b569ac07c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 @@ -984,8 +984,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTBC002', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC001', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC002', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'WATERTABLED',CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'FSWCHANGE' , CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_WATERLEVEL',CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) if (DO_GOSWIM /= 0) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RDU001', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index 32173c29d..fcaa65487 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -61,8 +61,8 @@ module GEOS_CatchCNCLM40GridCompMod use MAPL_ConstantsMod,only: Tzero => MAPL_TICE, pi => MAPL_PI use clm_time_manager, only: get_days_per_year, get_step_size use pftvarcon, only: noveg - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & - catch_calc_zbar, catch_calc_watertabled, irrigation_rate, & + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & + catch_calc_zbar, catch_calc_peatclsm_waterlevel, irrigation_rate, & gndtmp implicit none @@ -3737,9 +3737,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3748,7 +3748,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -4911,8 +4911,8 @@ subroutine Driver ( RC ) real, pointer, dimension(:) :: RMELTOC001 real, pointer, dimension(:) :: RMELTOC002 real, pointer, dimension(:) :: IRRIGRATE - real, pointer, dimension(:) :: WATERTABLED - real, pointer, dimension(:) :: FSWCHANGE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE ! -------------------------------------------------------------------------- ! Local pointers for tile variables @@ -5558,8 +5558,8 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,RMELTBC002,'RMELTBC002', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC001,'RMELTOC001', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC002,'RMELTOC002', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,WATERTABLED ,'WATERTABLED', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,FSWCHANGE , 'FSWCHANGE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL',RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE ,'PEATCLSM_FSWCHANGE', RC=STATUS); VERIFY_(STATUS) IF (RUN_IRRIG /= 0) call MAPL_GetPointer(EXPORT,IRRIGRATE ,'IRRIGRATE' , RC=STATUS); VERIFY_(STATUS) NTILES = size(PS) @@ -7806,9 +7806,16 @@ subroutine Driver ( RC ) if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) - if(associated(FSWCHANGE)) FSWCHANGE = FSW_CHANGE - if(associated(WATERTABLED)) then - WATERTABLED = catch_calc_watertabled( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + if(associated(PEATCLSM_FSWCHANGE)) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL)) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) endif if(associated(TPSN1OUT)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index 5caaa0425..5fa157104 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -61,8 +61,8 @@ module GEOS_CatchCNCLM45GridCompMod use MAPL_ConstantsMod,only: Tzero => MAPL_TICE, pi => MAPL_PI use clm_time_manager, only: get_days_per_year, get_step_size use pftvarcon, only: noveg - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & - catch_calc_zbar, catch_calc_watertabled, irrigation_rate, & + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & + catch_calc_zbar, catch_calc_peatclsm_waterlevel, irrigation_rate, & gndtmp use update_model_para4cn, only : upd_curr_date_time @@ -3675,9 +3675,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3686,7 +3686,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -4859,8 +4859,8 @@ subroutine Driver ( RC ) real, pointer, dimension(:) :: RMELTOC001 real, pointer, dimension(:) :: RMELTOC002 real, pointer, dimension(:) :: IRRIGRATE - real, pointer, dimension(:) :: WATERTABLED - real, pointer, dimension(:) :: FSWCHANGE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE ! -------------------------------------------------------------------------- ! Local pointers for tile variables @@ -5560,8 +5560,8 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,RMELTBC002 ,'RMELTBC002' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC001 ,'RMELTOC001' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC002 ,'RMELTOC002' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,WATERTABLED ,'WATERTABLED' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,FSWCHANGE ,'FSWCHANGE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE ,'PEATCLSM_FSWCHANGE' , RC=STATUS); VERIFY_(STATUS) IF (RUN_IRRIG /= 0) call MAPL_GetPointer(EXPORT,IRRIGRATE ,'IRRIGRATE' , RC=STATUS); VERIFY_(STATUS) @@ -8061,9 +8061,16 @@ subroutine Driver ( RC ) if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) - if(associated(FSWCHANGE)) FSWCHANGE = FSW_CHANGE - if(associated(WATERTABLED)) then - WATERTABLED = catch_calc_watertabled( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + if(associated(PEATCLSM_FSWCHANGE )) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL)) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) endif if(associated(TPSN1OUT)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index ebb728495..d767caee2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -45,7 +45,7 @@ module GEOS_CatchGridCompMod SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & SLOPE => CATCH_SNWALB_SLOPE - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_watertabled + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_peatclsm_waterlevel !#for_ldas_coupling use catch_incr @@ -2679,9 +2679,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -2690,7 +2690,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3927,8 +3927,8 @@ subroutine Driver ( RC ) real, pointer, dimension(:) :: RMELTBC002 real, pointer, dimension(:) :: RMELTOC001 real, pointer, dimension(:) :: RMELTOC002 - real, pointer, dimension(:) :: WATERTABLED - real, pointer, dimension(:) :: FSWCHANGE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE ! -------------------------------------------------------------------------- ! Local pointers for tile variables @@ -4468,8 +4468,8 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,RMELTBC002,'RMELTBC002', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC001,'RMELTOC001', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC002,'RMELTOC002', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,WATERTABLED,'WATERTABLED',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,FSWCHANGE, 'FSWCHANGE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL',RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE, 'PEATCLSM_FSWCHANGE', RC=STATUS); VERIFY_(STATUS) NTILES = size(PS) @@ -5644,9 +5644,16 @@ subroutine Driver ( RC ) if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) - if(associated(FSWCHANGE )) FSWCHANGE = FSW_CHANGE - if(associated(WATERTABLED )) then - WATERTABLED = catch_calc_watertabled( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + if(associated(PEATCLSM_FSWCHANGE )) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL )) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) endif if(associated(TPSN1)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 index 4f4835c2e..91e9377d0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 @@ -21,6 +21,9 @@ MODULE lsm_routines ! large-scale throughfalls. FWETC and FWETL are now passed through the resource file. ! reichle, 27 Jan 2022 - moved "public" constants & subroutine echo_catch_constants() to catch_constants.f90 + use MAPL, ONLY: & + MAPL_UNDEF + USE MAPL_ConstantsMod, ONLY: & PIE => MAPL_PI, & ! - TF => MAPL_TICE, & ! K @@ -55,7 +58,7 @@ MODULE lsm_routines PRIVATE PUBLIC :: INTERC, SRUNOFF, RZDRAIN, BASE, PARTITION, RZEQUIL, gndtp0 - PUBLIC :: SIBALB, catch_calc_soil_moist, catch_calc_zbar, catch_calc_watertabled + PUBLIC :: SIBALB, catch_calc_soil_moist, catch_calc_zbar, catch_calc_peatclsm_waterlevel PUBLIC :: catch_calc_subtile2tile PUBLIC :: gndtmp, catch_calc_tp, catch_calc_wtotl, catch_calc_ght, catch_calc_FT PUBLIC :: dampen_tc_oscillations, irrigation_rate @@ -1969,6 +1972,20 @@ end subroutine catch_calc_soil_moist ! Calculate zbar for Catchment[CN] model. ! + ! For mineral tiles, zbar is a fitted function that approximates the + ! water table depth EXCEPT for wet conditions. For low values of + ! catdef, negative values on the order of -1 meter can be encountered, + ! which would imply crazy water tables well above the surface. + ! For this reason, zbar is not suitable for general estimation + ! of water table depth. + ! + ! For PEATCLSM, zbar is a well-fitted function that describes the + ! water table depth for all wetness conditions. At zbar=0, half of + ! the microtopography is flooeded. Slightly negative values of + ! up to -14 cm (-bf2) are theoretically possible but are not realized. + ! Lesser negative values would represent slightly elevated water levels + ! that imply more than half of the microtopography is flooded. + ! ! Convention: zbar positive below ground (downward). ! ! This convention applies to water calculations, incl. subroutines RZDRAIN(), @@ -1979,7 +1996,8 @@ end subroutine catch_calc_soil_moist ! diffusion model, incl. subroutines GNDTP0(), GNDTMP(), GNDTMP_CN(). ! ! - reichle, 29 Jan 2022 - + ! - reichle, 3 Jun 2022 (updated documentation above) + function catch_calc_zbar_scalar( bf1, bf2, catdef ) result(zbar) implicit none @@ -2008,18 +2026,30 @@ end function catch_calc_zbar_vector ! ******************************************************************* - function catch_calc_watertabled( bf1, bf2, cdcr2, poros, wpwet, catdef ) result(wtd) + function catch_calc_peatclsm_waterlevel( bf1, bf2, cdcr2, poros, wpwet, catdef ) result(waterlevel) - ! calculate water table depth [m] + ! calculate water level (a.k.a. water table depth) for PEATCLSM only [m] + ! + ! Convention: water leve positive above ground (opposite of zbar convention!) implicit none real, dimension(:), intent(in) :: bf1, bf2, cdcr2, poros, wpwet, catdef - real, dimension(size(bf1)) :: wtd - - wtd = MIN( catch_calc_zbar(BF1,BF2,CATDEF), CDCR2/(1.-WPWET)/POROS/1000. ) + real, dimension(size(bf1)) :: waterlevel - end function catch_calc_watertabled + WHERE (POROS >= PEATCLSM_POROS_THRESHOLD) + + ! note change of sign from zbar + + waterlevel = -1.*MIN( catch_calc_zbar(BF1,BF2,CATDEF), CDCR2/(1.-WPWET)/POROS/1000. ) + + ELSEWHERE + + waterlevel = MAPL_UNDEF + + ENDWHERE + + end function catch_calc_peatclsm_waterlevel ! ******************************************************************* From 850d0a4e16caa350f2894beb878b380502f4243f Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 3 Jun 2022 20:27:56 -0400 Subject: [PATCH 21/21] fixed build error in previous commit (missing USE statement) --- .../GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 | 3 ++- .../GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 | 3 ++- .../GEOScatch_GridComp/GEOS_CatchGridComp.F90 | 4 +++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index fcaa65487..f434bd5c6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -51,7 +51,8 @@ module GEOS_CatchCNCLM40GridCompMod RHOFS => CATCH_SNWALB_RHOFS, & SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE + SLOPE => CATCH_SNWALB_SLOPE, & + PEATCLSM_POROS_THRESHOLD USE clm_varpar, ONLY : & NUM_ZON, NUM_VEG, VAR_COL, VAR_PFT, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index 5fa157104..4d38e55e0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -51,7 +51,8 @@ module GEOS_CatchCNCLM45GridCompMod RHOFS => CATCH_SNWALB_RHOFS, & SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE + SLOPE => CATCH_SNWALB_SLOPE, & + PEATCLSM_POROS_THRESHOLD USE clm_varpar, ONLY : & NUM_ZON, NUM_VEG, VAR_COL, VAR_PFT, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index d767caee2..de12911f0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -43,7 +43,9 @@ module GEOS_CatchGridCompMod RHOFS => CATCH_SNWALB_RHOFS, & SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE + SLOPE => CATCH_SNWALB_SLOPE, & + PEATCLSM_POROS_THRESHOLD + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_peatclsm_waterlevel