From 98d246199491d17ee80a2dd676a7a6a3376c4f54 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 29 Mar 2024 13:44:07 -0400 Subject: [PATCH 01/17] mods to limit COSP top --- src/control/cam_history_support.F90 | 6 +- src/physics/cam/cospsimulator_intr.F90 | 651 ++++++++++--------------- src/physics/cam/physpkg.F90 | 4 - 3 files changed, 259 insertions(+), 402 deletions(-) diff --git a/src/control/cam_history_support.F90 b/src/control/cam_history_support.F90 index 07ab2dd81a..940dc8c177 100644 --- a/src/control/cam_history_support.F90 +++ b/src/control/cam_history_support.F90 @@ -1407,7 +1407,7 @@ subroutine add_hist_coord_int(name, vlen, long_name, units, values, & if (i == 0) then call add_hist_coord(trim(name), i) if(masterproc) then - write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), & + write(iulog, '(3a,i0,a,i0)') 'Registering hist coord: ', trim(name), & '(', i, ') with length: ', vlen end if end if @@ -1472,7 +1472,7 @@ subroutine add_hist_coord_r8(name, vlen, long_name, units, values, & if (i == 0) then call add_hist_coord(trim(name), i) if(masterproc) then - write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), & + write(iulog, '(3a,i0,a,i0)') 'Registering hist coord: ', trim(name), & '(', i, ') with length: ', vlen end if end if @@ -1551,7 +1551,7 @@ subroutine add_vert_coord(name, vlen, long_name, units, values, & vertical_coord=.true.) i = get_hist_coord_index(trim(name)) if(masterproc) then - write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), & + write(iulog, '(3a,i0,a,i0)') 'Registering hist coord: ', trim(name), & '(', i, ') with length: ', vlen end if end if diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 6a01415f04..cb2246962d 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -13,6 +13,7 @@ module cospsimulator_intr use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + use ref_pres, only: ktop => trop_cloud_top_lev use perf_mod, only: t_startf, t_stopf use cam_abortutils, only: endrun use phys_control, only: cam_physpkg_is @@ -47,7 +48,6 @@ module cospsimulator_intr ! Public functions/subroutines public :: & cospsimulator_intr_readnl, & - cospsimulator_intr_register,& cospsimulator_intr_init, & cospsimulator_intr_run @@ -56,22 +56,22 @@ module cospsimulator_intr ! ###################################################################################### ! Whether to do COSP calcs and I/O, default is false. If docosp is specified in ! the atm_in namelist, this value is overwritten and cosp is run - logical, public :: docosp = .false. + logical, public, protected :: docosp = .false. ! Frequency at which cosp is called, every cosp_nradsteps radiation timestep - integer, public :: cosp_nradsteps = 1! CAM namelist variable default, not in COSP namelist + integer, public, protected :: cosp_nradsteps = 1 #ifdef USE_COSP ! ###################################################################################### ! Local declarations ! ###################################################################################### - integer, parameter :: & - nhtml_cosp = pver ! Mumber of model levels is pver integer :: & - nscol_cosp, & ! Number of subcolumns, use namelist input Ncolumns to set. + nlay, & ! Number of CAM layers used by COSP. + nscol_cosp, & ! Number of subcolumns, allow namelist input to set. nht_cosp ! Number of height for COSP radar and calipso simulator outputs. ! *set to 40 if csat_vgrid=.true., else set to Nlr* + ! ###################################################################################### ! Bin-boundaries for mixed dimensions. Calculated in cospsetupvales OR in cosp_config.F90 @@ -94,7 +94,6 @@ module cospsimulator_intr real(r8), target :: reffICE_binCenters_cosp(numMODISReffIceBins) real(r8), target :: reffLIQ_binCenters_cosp(numMODISReffLiqBins) - real(r8) :: htmlmid_cosp(nhtml_cosp) ! Model level height midpoints for output integer :: prstau_cosp(nprs_cosp*ntau_cosp) ! ISCCP mixed output dimension index integer :: prstau_cosp_modis(nprs_cosp*ntau_cosp_modis) ! MODIS mixed output dimension index integer :: htmisrtau_cosp(nhtmisr_cosp*ntau_cosp) ! MISR mixed output dimension index @@ -104,6 +103,7 @@ module cospsimulator_intr real(r8) :: prstau_taumid_cosp_modis(nprs_cosp*ntau_cosp_modis) real(r8) :: htmisrtau_htmisrmid_cosp(nhtmisr_cosp*ntau_cosp) real(r8) :: htmisrtau_taumid_cosp(nhtmisr_cosp*ntau_cosp) + real(r8),allocatable :: htmlmid_cosp(:) ! Model level height midpoints for output (nlay) real(r8),allocatable, public :: htdbze_dbzemid_cosp(:) ! (nht_cosp*CLOUDSAT_DBZE_BINS) real(r8),allocatable, target :: htlim_cosp(:,:) ! height limits for COSP outputs (nht_cosp+1) real(r8),allocatable, target :: htmid_cosp(:) ! height midpoints of COSP radar/lidar output (nht_cosp) @@ -111,65 +111,57 @@ module cospsimulator_intr real(r8),allocatable :: htdbze_htmid_cosp(:) ! (nht_cosp*CLOUDSAT_DBZE_BINS) real(r8),allocatable :: htsr_htmid_cosp(:) ! (nht_cosp*nsr_cosp) real(r8),allocatable :: htsr_srmid_cosp(:) ! (nht_cosp*nsr_cosp) - real(r8),allocatable :: htmlscol_htmlmid_cosp(:) ! (nhtml_cosp*nscol_cosp) - real(r8),allocatable :: htmlscol_scol_cosp(:) ! (nhtml_cosp*nscol_cosp) + real(r8),allocatable :: htmlscol_htmlmid_cosp(:) ! (nlay*nscol_cosp) + real(r8),allocatable :: htmlscol_scol_cosp(:) ! (nlay*nscol_cosp) integer, allocatable, target :: scol_cosp(:) ! sub-column number (nscol_cosp) integer, allocatable :: htdbze_cosp(:) ! radar CFAD mixed output dimension index (nht_cosp*CLOUDSAT_DBZE_BINS) integer, allocatable :: htsr_cosp(:) ! lidar CFAD mixed output dimension index (nht_cosp*nsr_cosp) - integer, allocatable :: htmlscol_cosp(:) ! html-subcolumn mixed output dimension index (nhtml_cosp*nscol_cosp) + integer, allocatable :: htmlscol_cosp(:) ! html-subcolumn mixed output dimension index (nlay*nscol_cosp) ! ###################################################################################### - ! Default namelists - ! The CAM and COSP namelists defaults are set below. Some of the COSP namelist - ! variables are part of the CAM namelist - they all begin with "cosp_" to keep their - ! names specific to COSP. I set their CAM namelist defaults here, not in namelist_defaults_cam.xml - ! Variables identified as namelist variables are defined in - ! ../models/atm/cam/bld/namelist_files/namelist_definition.xml + ! Default CAM namelist settings ! ###################################################################################### - ! CAM - logical :: cosp_amwg = .false. ! CAM namelist variable default, not in COSP namelist - logical :: cosp_lite = .false. ! CAM namelist variable default, not in COSP namelist - logical :: cosp_passive = .false. ! CAM namelist variable default, not in COSP namelist - logical :: cosp_active = .false. ! CAM namelist variable default, not in COSP namelist - logical :: cosp_isccp = .false. ! CAM namelist variable default, not in COSP namelist - logical :: cosp_lradar_sim = .false. ! CAM namelist variable default - logical :: cosp_llidar_sim = .false. ! CAM namelist variable default - logical :: cosp_lisccp_sim = .false. ! CAM namelist variable default - logical :: cosp_lmisr_sim = .false. ! CAM namelist variable default - logical :: cosp_lmodis_sim = .false. ! CAM namelist variable default - logical :: cosp_histfile_aux = .false. ! CAM namelist variable default - logical :: cosp_lfrac_out = .false. ! CAM namelist variable default - logical :: cosp_runall = .false. ! flag to run all of the cosp simulator package - integer :: cosp_ncolumns = 50 ! CAM namelist variable default - integer :: cosp_histfile_num =1 ! CAM namelist variable default, not in COSP namelist - integer :: cosp_histfile_aux_num =-1 ! CAM namelist variable default, not in COSP namelist + logical :: cosp_amwg = .false. + logical :: cosp_lite = .false. + logical :: cosp_passive = .false. + logical :: cosp_active = .false. + logical :: cosp_isccp = .false. + logical :: cosp_lradar_sim = .false. + logical :: cosp_llidar_sim = .false. + logical :: cosp_lisccp_sim = .false. + logical :: cosp_lmisr_sim = .false. + logical :: cosp_lmodis_sim = .false. + logical :: cosp_histfile_aux = .false. + logical :: cosp_lfrac_out = .false. + logical :: cosp_runall = .false. + integer :: cosp_ncolumns = 50 + integer :: cosp_histfile_num = 1 + integer :: cosp_histfile_aux_num = -1 ! COSP - logical :: lradar_sim = .false. ! COSP namelist variable, can be changed from default by CAM namelist - logical :: llidar_sim = .false. ! - logical :: lparasol_sim = .false. ! - logical :: lgrLidar532 = .false. ! - logical :: latlid = .false. ! - logical :: lisccp_sim = .false. ! "" - logical :: lmisr_sim = .false. ! "" - logical :: lmodis_sim = .false. ! "" - logical :: lrttov_sim = .false. ! not running rttov, always set to .false. - logical :: lfrac_out = .false. ! COSP namelist variable, can be changed from default by CAM namelist + logical :: lradar_sim = .false. + logical :: llidar_sim = .false. + logical :: lparasol_sim = .false. + logical :: lgrLidar532 = .false. + logical :: latlid = .false. + logical :: lisccp_sim = .false. + logical :: lmisr_sim = .false. + logical :: lmodis_sim = .false. + logical :: lrttov_sim = .false. + logical :: lfrac_out = .false. ! ###################################################################################### ! COSP parameters ! ###################################################################################### - ! Note: Unless otherwise specified, these are parameters that cannot be set by the CAM namelist. integer, parameter :: Npoints_it = 10000 ! Max # gridpoints to be processed in one iteration (10,000) - integer :: ncolumns = 50 ! Number of subcolumns in SCOPS (50), can be changed from default by CAM namelist + integer :: ncolumns = 50 ! Number of subcolumns in SCOPS (50) integer :: nlr = 40 ! Number of levels in statistical outputs ! (only used if USE_VGRID=.true.) (40) logical :: use_vgrid = .true. ! Use fixed vertical grid for outputs? ! (if .true. then define # of levels with nlr) (.true.) logical :: csat_vgrid = .true. ! CloudSat vertical grid? - ! (if .true. then the CloudSat standard grid is used. - ! If set, overides use_vgrid.) (.true.) - ! namelist variables for COSP input related to radar simulator + + ! Variables for COSP input related to radar simulator real(r8) :: radar_freq = 94.0_r8 ! CloudSat radar frequency (GHz) (94.0) integer :: surface_radar = 0 ! surface=1, spaceborne=0 (0) integer :: use_mie_tables = 0 ! use a precomputed lookup table? yes=1,no=0 (0) @@ -177,7 +169,8 @@ module cospsimulator_intr integer :: do_ray = 0 ! calculate/output Rayleigh refl=1, not=0 (0) integer :: melt_lay = 0 ! melting layer model off=0, on=1 (0) real(r8) :: k2 = -1 ! |K|^2, -1=use frequency dependent default (-1) - ! namelist variables for COSP input related to lidar simulator + + ! Variables for COSP input related to lidar simulator integer, parameter :: Nprmts_max_hydro = 12 ! Max # params for hydrometeor size distributions (12) integer, parameter :: Naero = 1 ! Number of aerosol species (Not used) (1) integer, parameter :: Nprmts_max_aero = 1 ! Max # params for aerosol size distributions (not used) (1) @@ -185,7 +178,7 @@ module cospsimulator_intr ! (0=ice-spheres ; 1=ice-non-spherical) (0) integer, parameter :: overlap = 3 ! overlap type: 1=max, 2=rand, 3=max/rand (3) - !! namelist variables for COSP input related to ISCCP simulator + ! Variables for COSP input related to ISCCP simulator integer :: isccp_topheight = 1 ! 1 = adjust top height using both a computed infrared ! brightness temperature and the visible ! optical depth to adjust cloud top pressure. @@ -268,188 +261,35 @@ module cospsimulator_intr CONTAINS - ! ###################################################################################### - ! SUBROUTINE setcosp2values - ! ###################################################################################### -#ifdef USE_COSP - subroutine setcosp2values(Nlr_in,use_vgrid_in,csat_vgrid_in,Ncolumns_in,cosp_nradsteps_in) - use mod_cosp, only: cosp_init - use mod_cosp_config, only: vgrid_zl, vgrid_zu, vgrid_z - use mod_quickbeam_optics, only: hydro_class_init, quickbeam_optics_init - ! Inputs - integer, intent(in) :: Nlr_in ! Number of vertical levels for CALIPSO and Cloudsat products - integer, intent(in) :: Ncolumns_in ! Number of sub-columns - integer, intent(in) :: cosp_nradsteps_in ! How often to call COSP? - logical, intent(in) :: use_vgrid_in ! Logical switch to use interpolated, to Nlr_in, grid for CALIPSO and Cloudsat - logical, intent(in) :: csat_vgrid_in ! - - ! Local - logical :: ldouble=.false. - logical :: lsingle=.true. ! Default is to use single moment - integer :: i,k - - prsmid_cosp = pres_binCenters - prslim_cosp = pres_binEdges - taumid_cosp = tau_binCenters - taulim_cosp = tau_binEdges - srmid_cosp = calipso_binCenters - srlim_cosp = calipso_binEdges - sza_cosp = parasol_sza - dbzemid_cosp = cloudsat_binCenters - dbzelim_cosp = cloudsat_binEdges - htmisrmid_cosp = misr_histHgtCenters - htmisrlim_cosp = misr_histHgtEdges - taumid_cosp_modis = tau_binCenters - taulim_cosp_modis = tau_binEdges - reffICE_binCenters_cosp = reffICE_binCenters - reffICE_binEdges_cosp = reffICE_binEdges - reffLIQ_binCenters_cosp = reffLIQ_binCenters - reffLIQ_binEdges_cosp = reffLIQ_binEdges - - ! Initialize the distributional parameters for hydrometeors in radar simulator. In COSPv1.4, this was declared in - ! cosp_defs.f. - if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then - ldouble = .true. - lsingle = .false. - endif - call hydro_class_init(lsingle,ldouble,sd) - call quickbeam_optics_init() - - ! DS2017: The setting up of the vertical grid for regridding the CALIPSO and Cloudsat products is - ! now donein cosp_init, but these fields are stored in cosp_config.F90. - ! Additionally all static fields used by the individual simulators are set up by calls - ! to _init functions in cosp_init. - ! DS2019: Add logicals, default=.false., for new Lidar simuldators (Earthcare (atlid) and ground-based - ! lidar at 532nm) - call COSP_INIT(Lisccp_sim, Lmodis_sim, Lmisr_sim, Lradar_sim, Llidar_sim, LgrLidar532, & - Latlid, Lparasol_sim, Lrttov_sim, radar_freq, k2, use_gas_abs, do_ray, & - isccp_topheight, isccp_topheight_direction, surface_radar, rcfg_cloudsat, & - use_vgrid_in, csat_vgrid_in, Nlr_in, pver, cloudsat_micro_scheme) - - ! Set number of sub-columns, from namelist - nscol_cosp = Ncolumns_in - - if (use_vgrid_in) then !! using fixed vertical grid - if (csat_vgrid_in) then - nht_cosp = 40 - else - nht_cosp = Nlr_in - endif - endif - - ! Set COSP call frequency, from namelist. - cosp_nradsteps = cosp_nradsteps_in - - ! DJS2017: In COSP2, most of the bin boundaries, centers, and edges are declared in src/cosp_config.F90. - ! Above I just assign them accordingly in the USE statement. Other bin bounds needed by CAM - ! are calculated here. - ! Allocate - allocate(htlim_cosp(2,nht_cosp),htlim_cosp_1d(nht_cosp+1),htmid_cosp(nht_cosp),scol_cosp(nscol_cosp), & - htdbze_cosp(nht_cosp*CLOUDSAT_DBZE_BINS),htsr_cosp(nht_cosp*nsr_cosp),htmlscol_cosp(nhtml_cosp*nscol_cosp),& - htdbze_htmid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS),htdbze_dbzemid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), & - htsr_htmid_cosp(nht_cosp*nsr_cosp),htsr_srmid_cosp(nht_cosp*nsr_cosp), & - htmlscol_htmlmid_cosp(nhtml_cosp*nscol_cosp),htmlscol_scol_cosp(nhtml_cosp*nscol_cosp)) - - ! DJS2017: Just pull from cosp_config - if (use_vgrid_in) then - htlim_cosp_1d(1) = vgrid_zu(1) - htlim_cosp_1d(2:nht_cosp+1) = vgrid_zl - endif - htmid_cosp = vgrid_z - htlim_cosp(1,:) = vgrid_zu - htlim_cosp(2,:) = vgrid_zl - - scol_cosp(:) = (/(k,k=1,nscol_cosp)/) - - ! Just using an index here, model height is a prognostic variable - htmlmid_cosp(:) = (/(k,k=1,nhtml_cosp)/) - - ! assign mixed dimensions an integer index for cam_history.F90 - do k=1,nprs_cosp*ntau_cosp - prstau_cosp(k) = k - end do - do k=1,nprs_cosp*ntau_cosp_modis - prstau_cosp_modis(k) = k - end do - do k=1,nht_cosp*CLOUDSAT_DBZE_BINS - htdbze_cosp(k) = k - end do - do k=1,nht_cosp*nsr_cosp - htsr_cosp(k) = k - end do - do k=1,nhtml_cosp*nscol_cosp - htmlscol_cosp(k) = k - end do - do k=1,nhtmisr_cosp*ntau_cosp - htmisrtau_cosp(k) = k - end do - - ! next, assign collapsed reference vectors for cam_history.F90 - ! convention for saving output = prs1,tau1 ... prs1,tau7 ; prs2,tau1 ... prs2,tau7 etc. - ! actual output is specified in cospsimulator1_intr.F90 - do k=1,nprs_cosp - prstau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp) - prstau_prsmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=prsmid_cosp(k) - prstau_taumid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=taumid_cosp_modis(1:ntau_cosp_modis) - prstau_prsmid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=prsmid_cosp(k) - enddo - - do k=1,nht_cosp - htdbze_dbzemid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=dbzemid_cosp(1:CLOUDSAT_DBZE_BINS) - htdbze_htmid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=htmid_cosp(k) - enddo - - do k=1,nht_cosp - htsr_srmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=srmid_cosp(1:nsr_cosp) - htsr_htmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=htmid_cosp(k) - enddo - - do k=1,nhtml_cosp - htmlscol_scol_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=scol_cosp(1:nscol_cosp) - htmlscol_htmlmid_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=htmlmid_cosp(k) - enddo - - do k=1,nhtmisr_cosp - htmisrtau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp) - htmisrtau_htmisrmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=htmisrmid_cosp(k) - enddo - - end subroutine setcosp2values -#endif - ! ###################################################################################### ! SUBROUTINE cospsimulator_intr_readnl ! - ! PURPOSE: to read namelist variables and run setcospvalues subroutine.note: cldfrc_readnl - ! is a good template in cloud_fraction.F90. Make sure that this routine is reading in a - ! namelist. models/atm/cam/bld/build-namelist is the perl script to check. + ! Read namelist variables and run setcospvalues subroutine. ! ###################################################################################### subroutine cospsimulator_intr_readnl(nlfile) use namelist_utils, only: find_group_name use units, only: getunit, freeunit #ifdef SPMD - use mpishorthand, only: mpicom, mpilog, mpiint, mpichar + use mpishorthand, only: mpicom, mpilog, mpiint #endif - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input (nlfile=atm_in) + character(len=*), intent(in) :: nlfile ! file containing namelist input (nlfile=atm_in) ! Local variables integer :: unitn, ierr character(len=*), parameter :: subname = 'cospsimulator_intr_readnl' #ifdef USE_COSP -!!! this list should include any variable that you might want to include in the namelist -!!! philosophy is to not include COSP output flags but just important COSP settings and cfmip controls. - namelist /cospsimulator_nl/ docosp, cosp_active, cosp_amwg, & - cosp_histfile_num, cosp_histfile_aux, cosp_histfile_aux_num, cosp_isccp, cosp_lfrac_out, & - cosp_lite, cosp_lradar_sim, cosp_llidar_sim, cosp_lisccp_sim, cosp_lmisr_sim, cosp_lmodis_sim, cosp_ncolumns, & - cosp_nradsteps, cosp_passive, cosp_runall + namelist /cospsimulator_nl/ docosp, cosp_ncolumns, cosp_nradsteps, & + cosp_amwg, cosp_lite, cosp_passive, cosp_active, cosp_isccp, cosp_runall, & + cosp_lfrac_out, cosp_lradar_sim, cosp_llidar_sim, cosp_lisccp_sim, & + cosp_lmisr_sim, cosp_lmodis_sim, & + cosp_histfile_num, cosp_histfile_aux, cosp_histfile_aux_num !! read in the namelist if (masterproc) then unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) !! presumably opens the namelist file "nlfile" - !! position the file to write to the cospsimulator portion of the cam_in namelist + open( unitn, file=trim(nlfile), status='old' ) call find_group_name(unitn, 'cospsimulator_nl', status=ierr) if (ierr == 0) then read(unitn, cospsimulator_nl, iostat=ierr) @@ -565,24 +405,17 @@ subroutine cospsimulator_intr_readnl(nlfile) cosp_nradsteps = 3 end if - !! reset COSP namelist variables based on input from cam namelist variables - if (cosp_ncolumns .ne. ncolumns) then - ncolumns = cosp_ncolumns - end if + ! Set number of sub-columns, from namelist + ncolumns = cosp_ncolumns + nscol_cosp = cosp_ncolumns - ! *NOTE* COSP is configured in CAM such that if a simulator is requested, all diagnostics - ! are output. So no need turn on/aff outputs if simulator is requested. - - ! Set vertical coordinate, subcolumn, and calculation frequency cosp options based on namelist inputs - call setcosp2values(nlr,use_vgrid,csat_vgrid,ncolumns,cosp_nradsteps) - if (masterproc) then if (docosp) then write(iulog,*)'COSP configuration:' write(iulog,*)' Number of COSP subcolumns = ', cosp_ncolumns - write(iulog,*)' Frequency at which cosp is called = ', cosp_nradsteps + write(iulog,*)' COSP frequency in radiation steps = ', cosp_nradsteps write(iulog,*)' Enable radar simulator = ', lradar_sim - write(iulog,*)' Enable calipso simulator = ', llidar_sim + write(iulog,*)' Enable calipso simulator = ', llidar_sim write(iulog,*)' Enable ISCCP simulator = ', lisccp_sim write(iulog,*)' Enable MISR simulator = ', lmisr_sim write(iulog,*)' Enable MODIS simulator = ', lmodis_sim @@ -590,7 +423,7 @@ subroutine cospsimulator_intr_readnl(nlfile) write(iulog,*)' Write COSP output to history file = ', cosp_histfile_num write(iulog,*)' Write COSP input fields = ', cosp_histfile_aux write(iulog,*)' Write COSP input fields to history file = ', cosp_histfile_aux_num - write(iulog,*)' Write COSP subcolumn fields = ', cosp_lfrac_out + write(iulog,*)' Write COSP subcolumn fields = ', lfrac_out else write(iulog,*)'COSP not enabled' end if @@ -599,14 +432,29 @@ subroutine cospsimulator_intr_readnl(nlfile) end subroutine cospsimulator_intr_readnl ! ###################################################################################### - ! SUBROUTINE cospsimulator_intr_register + ! SUBROUTINE cospsimulator_intr_init ! ###################################################################################### - subroutine cospsimulator_intr_register() + subroutine cospsimulator_intr_init() + +#ifdef USE_COSP + use cam_history, only: addfld, add_default, horiz_only use cam_history_support, only: add_hist_coord + use physics_buffer, only: pbuf_get_index + + use mod_cosp_config, only : R_UNDEF -#ifdef USE_COSP - ! register non-standard variable dimensions + integer :: i, ierr + !--------------------------------------------------------------------------- + + ! Set number of levels used by COSP to the number of levels used by + ! CAM's cloud macro/microphysics parameterizations. + nlay = pver - ktop + 1 + + ! COSP initialization + call setcosp2values() + + ! Define coordinate variables for COSP outputs. if (lisccp_sim .or. lmodis_sim) then call add_hist_coord('cosp_prs', nprs_cosp, 'COSP Mean ISCCP pressure', & 'hPa', prsmid_cosp, bounds_name='cosp_prs_bnds', bounds=prslim_cosp) @@ -665,30 +513,6 @@ subroutine cospsimulator_intr_register() bounds_name='cosp_reffliq_bnds',bounds=reffLIQ_binEdges_cosp) end if -#endif - end subroutine cospsimulator_intr_register - - ! ###################################################################################### - ! SUBROUTINE cospsimulator_intr_init - ! ###################################################################################### - subroutine cospsimulator_intr_init() - -#ifdef USE_COSP - - use cam_history, only: addfld, add_default, horiz_only -#ifdef SPMD - use mpishorthand, only : mpir8, mpiint, mpicom -#endif - use netcdf, only : nf90_open, nf90_inq_varid, nf90_get_var, nf90_close, nf90_nowrite - use error_messages, only : handle_ncerr, alloc_err - - use physics_buffer, only: pbuf_get_index - - use mod_cosp_config, only : R_UNDEF - - integer :: ncid,latid,lonid,did,hrid,minid,secid, istat - integer :: i, ierr - ! ISCCP OUTPUTS if (lisccp_sim) then !! addfld calls for all @@ -819,40 +643,6 @@ subroutine cospsimulator_intr_init() call addfld('CLDLOW_CAL_UN',horiz_only,'A','percent','Calipso Low-level Undefined-Phase Cloud Fraction', & flag_xyfill=.true., fill_value=R_UNDEF) -! ! Calipso Opaque/thin cloud diagnostics -! call addfld('CLDOPQ_CAL', horiz_only, 'A', 'percent', 'CALIPSO Opaque Cloud Cover', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDTHN_CAL', horiz_only, 'A', 'percent', 'CALIPSO Thin Cloud Cover', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDZOPQ_CAL', horiz_only, 'A', 'm', 'CALIPSO z_opaque Altitude', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDOPQ_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO Opaque Cloud Fraction', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDTHN_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO Thin Cloud Fraction', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDZOPQ_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO z_opaque Fraction', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('OPACITY_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO opacity Fraction', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDOPQ_CAL_TMP', horiz_only, 'A', 'K', 'CALIPSO Opaque Cloud Temperature', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDTHN_CAL_TMP', horiz_only, 'A', 'K', 'CALIPSO Thin Cloud Temperature', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDZOPQ_CAL_TMP', horiz_only, 'A', 'K', 'CALIPSO z_opaque Temperature', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDOPQ_CAL_Z', horiz_only, 'A', 'm', 'CALIPSO Opaque Cloud Altitude', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDTHN_CAL_Z', horiz_only, 'A', 'm', 'CALIPSO Thin Cloud Altitude', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDTHN_CAL_EMIS', horiz_only, 'A', '1', 'CALIPSO Thin Cloud Emissivity', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDOPQ_CAL_SE', horiz_only, 'A', 'm', 'CALIPSO Opaque Cloud Altitude with respect to surface-elevation', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDTHN_CAL_SE', horiz_only, 'A', 'm', 'CALIPSO Thin Cloud Altitude with respect to surface-elevation', & -! flag_xyfill=.true., fill_value=R_UNDEF) -! call addfld('CLDZOPQ_CAL_SE', horiz_only, 'A', 'm', 'CALIPSO z_opaque Altitude with respect to surface-elevation', & -! flag_xyfill=.true., fill_value=R_UNDEF) - ! add_default calls for CFMIP experiments or else all fields are added to history file ! except those with sub-column dimension/experimental variables !! add all calipso outputs to the history file specified by the CAM namelist variable cosp_histfile_num @@ -878,22 +668,6 @@ subroutine cospsimulator_intr_init() call add_default ('CLDLOW_CAL_ICE',cosp_histfile_num,' ') call add_default ('CLDLOW_CAL_LIQ',cosp_histfile_num,' ') call add_default ('CLDLOW_CAL_UN',cosp_histfile_num,' ') -! call add_default ('CLDOPQ_CAL',cosp_histfile_num,' ') -! call add_default ('CLDTHN_CAL',cosp_histfile_num,' ') -! call add_default ('CLDZOPQ_CAL',cosp_histfile_num,' ') -! call add_default ('CLDOPQ_CAL_2D',cosp_histfile_num,' ') -! call add_default ('CLDTHN_CAL_2D',cosp_histfile_num,' ') -! call add_default ('CLDZOPQ_CAL_2D',cosp_histfile_num,' ') -! call add_default ('OPACITY_CAL_2D',cosp_histfile_num,' ') -! call add_default ('CLDOPQ_CAL_TMP',cosp_histfile_num,' ') -! call add_default ('CLDTHN_CAL_TMP',cosp_histfile_num,' ') -! call add_default ('CLDZOPQ_CAL_TMP',cosp_histfile_num,' ') -! call add_default ('CLDOPQ_CAL_Z',cosp_histfile_num,' ') -! call add_default ('CLDTHN_CAL_Z',cosp_histfile_num,' ') -! call add_default ('CLDTHN_CAL_EMIS',cosp_histfile_num,' ') -! call add_default ('CLDOPQ_CAL_SE',cosp_histfile_num,' ') -! call add_default ('CLDTHN_CAL_SE',cosp_histfile_num,' ') -! call add_default ('CLDZOPQ_CAL_SE',cosp_histfile_num,' ') if ((.not.cosp_amwg) .and. (.not.cosp_lite) .and. (.not.cosp_passive) .and. (.not.cosp_active) & .and. (.not.cosp_isccp)) then @@ -941,13 +715,6 @@ subroutine cospsimulator_intr_init() call addfld('CS_RAINHARD', horiz_only, 'A', '1', 'CloudSat Heavy Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CS_UN', horiz_only, 'A', '1', 'CloudSat Unclassified Precipitation Fraction',flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CS_PIA', horiz_only, 'A', 'dBZ', 'CloudSat Radar Path Integrated Attenuation', flag_xyfill=.true., fill_value=R_UNDEF) - ! Associated CAM microphysics - !call addfld('CAM_MP_CVRAIN',horiz_only, 'A', 'kg/kg','CAM Microphysics Convective Rain', flag_xyfill=.true., fill_value=R_UNDEF) - !call addfld('CAM_MP_CVSNOW',horiz_only, 'A', 'kg/kg','CAM Microphysics Convective Snow', flag_xyfill=.true., fill_value=R_UNDEF) - !call addfld('CAM_MP_LSRAIN',horiz_only, 'A', 'kg/kg','CAM Microphysics Large-Scale Rain', flag_xyfill=.true., fill_value=R_UNDEF) - !call addfld('CAM_MP_LSSNOW',horiz_only, 'A', 'kg/kg','CAM Microphysics Large-Scale Snow', flag_xyfill=.true., fill_value=R_UNDEF) - !call addfld('CAM_MP_LSGRPL',horiz_only, 'A', 'kg/kg','CAM Microphysics Large-Scale Graupel', flag_xyfill=.true., fill_value=R_UNDEF) - ! add_default calls for CFMIP experiments or else all fields are added to history file except those with sub-column dimension !! add all radar outputs to the history file specified by the CAM namelist variable cosp_histfile_num @@ -1181,6 +948,153 @@ subroutine cospsimulator_intr_init() #endif end subroutine cospsimulator_intr_init + ! ###################################################################################### + ! SUBROUTINE setcosp2values + ! ###################################################################################### +#ifdef USE_COSP + subroutine setcosp2values() + use mod_cosp, only: cosp_init + use mod_cosp_config, only: vgrid_zl, vgrid_zu, vgrid_z + use mod_quickbeam_optics, only: hydro_class_init, quickbeam_optics_init + + ! Local + logical :: ldouble=.false. + logical :: lsingle=.true. ! Default is to use single moment + integer :: i,k + + prsmid_cosp = pres_binCenters + prslim_cosp = pres_binEdges + taumid_cosp = tau_binCenters + taulim_cosp = tau_binEdges + srmid_cosp = calipso_binCenters + srlim_cosp = calipso_binEdges + sza_cosp = parasol_sza + dbzemid_cosp = cloudsat_binCenters + dbzelim_cosp = cloudsat_binEdges + htmisrmid_cosp = misr_histHgtCenters + htmisrlim_cosp = misr_histHgtEdges + taumid_cosp_modis = tau_binCenters + taulim_cosp_modis = tau_binEdges + reffICE_binCenters_cosp = reffICE_binCenters + reffICE_binEdges_cosp = reffICE_binEdges + reffLIQ_binCenters_cosp = reffLIQ_binCenters + reffLIQ_binEdges_cosp = reffLIQ_binEdges + + ! Initialize the distributional parameters for hydrometeors in radar simulator. In COSPv1.4, this was declared in + ! cosp_defs.f. + if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then + ldouble = .true. + lsingle = .false. + endif + call hydro_class_init(lsingle,ldouble,sd) + call quickbeam_optics_init() + + ! DS2017: The setting up of the vertical grid for regridding the CALIPSO and Cloudsat products is + ! now donein cosp_init, but these fields are stored in cosp_config.F90. + ! Additionally all static fields used by the individual simulators are set up by calls + ! to _init functions in cosp_init. + ! DS2019: Add logicals, default=.false., for new Lidar simuldators (Earthcare (atlid) and ground-based + ! lidar at 532nm) + call COSP_INIT(Lisccp_sim, Lmodis_sim, Lmisr_sim, Lradar_sim, Llidar_sim, LgrLidar532, & + Latlid, Lparasol_sim, Lrttov_sim, radar_freq, k2, use_gas_abs, do_ray, & + isccp_topheight, isccp_topheight_direction, surface_radar, rcfg_cloudsat, & + use_vgrid, csat_vgrid, Nlr, nlay, cloudsat_micro_scheme) + + if (use_vgrid) then !! using fixed vertical grid + if (csat_vgrid) then + nht_cosp = 40 + else + nht_cosp = Nlr + endif + endif + + ! DJS2017: In COSP2, most of the bin boundaries, centers, and edges are declared in src/cosp_config.F90. + ! Above I just assign them accordingly in the USE statement. Other bin bounds needed by CAM + ! are calculated here. + + allocate( & + htmlmid_cosp(nlay), & + htdbze_dbzemid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), & + htlim_cosp(2,nht_cosp), & + htmid_cosp(nht_cosp), & + htlim_cosp_1d(nht_cosp+1), & + htdbze_htmid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), & + htsr_htmid_cosp(nht_cosp*nsr_cosp), & + htsr_srmid_cosp(nht_cosp*nsr_cosp), & + htmlscol_htmlmid_cosp(nlay*nscol_cosp), & + htmlscol_scol_cosp(nlay*nscol_cosp), & + scol_cosp(nscol_cosp), & + htdbze_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), & + htsr_cosp(nht_cosp*nsr_cosp), & + htmlscol_cosp(nlay*nscol_cosp) ) + + ! DJS2017: Just pull from cosp_config + if (use_vgrid) then + htlim_cosp_1d(1) = vgrid_zu(1) + htlim_cosp_1d(2:nht_cosp+1) = vgrid_zl + endif + htmid_cosp = vgrid_z + htlim_cosp(1,:) = vgrid_zu + htlim_cosp(2,:) = vgrid_zl + + scol_cosp(:) = (/(k,k=1,nscol_cosp)/) + + ! Just using an index here, model height is a prognostic variable + htmlmid_cosp(:) = (/(k,k=1,nlay)/) + + ! assign mixed dimensions an integer index for cam_history.F90 + do k=1,nprs_cosp*ntau_cosp + prstau_cosp(k) = k + end do + do k=1,nprs_cosp*ntau_cosp_modis + prstau_cosp_modis(k) = k + end do + do k=1,nht_cosp*CLOUDSAT_DBZE_BINS + htdbze_cosp(k) = k + end do + do k=1,nht_cosp*nsr_cosp + htsr_cosp(k) = k + end do + do k=1,nlay*nscol_cosp + htmlscol_cosp(k) = k + end do + do k=1,nhtmisr_cosp*ntau_cosp + htmisrtau_cosp(k) = k + end do + + ! next, assign collapsed reference vectors for cam_history.F90 + ! convention for saving output = prs1,tau1 ... prs1,tau7 ; prs2,tau1 ... prs2,tau7 etc. + ! actual output is specified in cospsimulator1_intr.F90 + do k=1,nprs_cosp + prstau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp) + prstau_prsmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=prsmid_cosp(k) + prstau_taumid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=taumid_cosp_modis(1:ntau_cosp_modis) + prstau_prsmid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=prsmid_cosp(k) + enddo + + do k=1,nht_cosp + htdbze_dbzemid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=dbzemid_cosp(1:CLOUDSAT_DBZE_BINS) + htdbze_htmid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=htmid_cosp(k) + enddo + + do k=1,nht_cosp + htsr_srmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=srmid_cosp(1:nsr_cosp) + htsr_htmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=htmid_cosp(k) + enddo + + do k=1,nlay + htmlscol_scol_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=scol_cosp(1:nscol_cosp) + htmlscol_htmlmid_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=htmlmid_cosp(k) + enddo + + do k=1,nhtmisr_cosp + htmisrtau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp) + htmisrtau_htmisrmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=htmisrmid_cosp(k) + enddo + + end subroutine setcosp2values +#endif + ! ###################################################################################### ! SUBROUTINE cospsimulator_intr_run ! ###################################################################################### @@ -1291,11 +1205,10 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! COSP input variables that depend on CAM ! 1) Npoints = number of gridpoints COSP will process (without subsetting, Npoints=ncol) - ! 2) Nlevels = number of model levels (Nlevels=pver) + real(r8), parameter :: time = 1.0_r8 ! time ! Time since start of run [days], set to 1 bc running over single CAM timestep real(r8), parameter :: time_bnds(2)=(/0.5_r8,1.5_r8/) ! time_bnds ! Time boundaries - new in cosp v1.3, set following cosp_test.f90 line 121 integer :: Npoints ! Number of gridpoints COSP will process - integer :: Nlevels ! Nlevels logical :: use_reff ! True if effective radius to be used by radar simulator ! (always used by lidar) logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm @@ -1435,7 +1348,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! 1) use pcols (maximum number of columns that code could use, maybe 16) ! pcols vs. ncol. ncol is the number of columns a chunk is actually using, pcols is maximum number ! 2) Mixed variables rules/notes, need to collapse because CAM history does not support increased dimensionality - ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nhtml_cosp, ntau_cosp*nhtmisr_cosp + ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nlay, ntau_cosp*nhtmisr_cosp ! a) always making mixed variables VERTICAL*OTHER, e.g., pressure*tau or ht*dbze ! b) always collapsing output as V1_1/V2_1...V1_1/V2_N ; V1_2/V2_1 ...V1_2/V2_N etc. to V1_N/V2_1 ... V1_N/V2_N ! c) here, need vars for both multi-dimensional output from COSP, and two-dimensional output from CAM @@ -1447,10 +1360,10 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8) :: clisccp2(pcols,ntau_cosp,nprs_cosp) ! clisccp2 (time,tau,plev,profile) real(r8) :: cfad_dbze94(pcols,CLOUDSAT_DBZE_BINS,nht_cosp) ! cfad_dbze94 (time,height,dbze,profile) real(r8) :: cfad_lidarsr532(pcols,nsr_cosp,nht_cosp) ! cfad_lidarsr532 (time,height,scat_ratio,profile) - real(r8) :: dbze94(pcols,nscol_cosp,nhtml_cosp) ! dbze94 (time,height_mlev,column,profile) - real(r8) :: atb532(pcols,nscol_cosp,nhtml_cosp) ! atb532 (time,height_mlev,column,profile) + real(r8) :: dbze94(pcols,nscol_cosp,nlay) ! dbze94 (time,height_mlev,column,profile) + real(r8) :: atb532(pcols,nscol_cosp,nlay) ! atb532 (time,height_mlev,column,profile) real(r8) :: clMISR(pcols,ntau_cosp,nhtmisr_cosp) ! clMISR (time,tau,CTH_height_bin,profile) - real(r8) :: frac_out(pcols,nscol_cosp,nhtml_cosp) ! frac_out (time,height_mlev,column,profile) + real(r8) :: frac_out(pcols,nscol_cosp,nlay) ! frac_out (time,height_mlev,column,profile) real(r8) :: cldtot_isccp(pcols) ! CAM tclisccp (time,profile) real(r8) :: meancldalb_isccp(pcols) ! CAM albisccp (time,profile) real(r8) :: meanptop_isccp(pcols) ! CAM ctpisccp (time,profile) @@ -1478,22 +1391,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8) :: cld_cal_tmpliq(pcols,nht_cosp) ! CAM (time,height,profile) real(r8) :: cld_cal_tmpice(pcols,nht_cosp) ! CAM (time,height,profile) real(r8) :: cld_cal_tmpun(pcols,nht_cosp) ! CAM (time,height,profile) !+cosp1.4 -! real(r8) :: cldopaq_cal(pcols) -! real(r8) :: cldthin_cal(pcols) -! real(r8) :: cldopaqz_cal(pcols) -! real(r8) :: cldopaq_cal_temp(pcols) -! real(r8) :: cldthin_cal_temp(pcols) -! real(r8) :: cldzopaq_cal_temp(pcols) -! real(r8) :: cldopaq_cal_z(pcols) -! real(r8) :: cldthin_cal_z(pcols) -! real(r8) :: cldthin_cal_emis(pcols) -! real(r8) :: cldopaq_cal_se(pcols) -! real(r8) :: cldthin_cal_se(pcols) -! real(r8) :: cldzopaq_cal_se(pcols) -! real(r8) :: cldopaq_cal_2d(pcols,nht_cosp) -! real(r8) :: cldthin_cal_2d(pcols,nht_cosp) -! real(r8) :: cldzopaq_cal_2d(pcols,nht_cosp) -! real(r8) :: opacity_cal_2d(pcols,nht_cosp) real(r8) :: cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS)! CAM cfad_dbze94 (time,height,dbze,profile) real(r8) :: cfad_sr532_cal(pcols,nht_cosp*nsr_cosp) ! CAM cfad_lidarsr532 (time,height,scat_ratio,profile) real(r8) :: tau_isccp(pcols,nscol_cosp) ! CAM boxtauisccp (time,column,profile) @@ -1501,7 +1398,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8) :: meantau_isccp(pcols) ! CAM tauisccp (time,profile) real(r8) :: meantb_isccp(pcols) ! CAM meantbisccp (time,profile) real(r8) :: meantbclr_isccp(pcols) ! CAM meantbclrisccp (time,profile) - real(r8) :: dbze_cs(pcols,nhtml_cosp*nscol_cosp) ! CAM dbze94 (time,height_mlev,column,profile) + real(r8) :: dbze_cs(pcols,nlay*nscol_cosp) ! CAM dbze94 (time,height_mlev,column,profile) real(r8) :: cldtot_calcs(pcols) ! CAM cltlidarradar (time,profile) real(r8) :: cldtot_cs(pcols) ! CAM cltradar (time,profile) real(r8) :: cldtot_cs2(pcols) ! CAM cltradar2 (time,profile) @@ -1517,11 +1414,11 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8) :: ptcloudsatflag9(pcols) real(r8) :: cloudsatpia(pcols) real(r8) :: cld_cal_notcs(pcols,nht_cosp) ! CAM clcalipso2 (time,height,profile) - real(r8) :: atb532_cal(pcols,nhtml_cosp*nscol_cosp) ! CAM atb532 (time,height_mlev,column,profile) - real(r8) :: mol532_cal(pcols,nhtml_cosp) ! CAM beta_mol532 (time,height_mlev,profile) + real(r8) :: atb532_cal(pcols,nlay*nscol_cosp) ! CAM atb532 (time,height_mlev,column,profile) + real(r8) :: mol532_cal(pcols,nlay) ! CAM beta_mol532 (time,height_mlev,profile) real(r8) :: cld_misr(pcols,nhtmisr_cosp*ntau_cosp) ! CAM clMISR (time,tau,CTH_height_bin,profile) real(r8) :: refl_parasol(pcols,nsza_cosp) ! CAM parasol_refl (time,sza,profile) - real(r8) :: scops_out(pcols,nhtml_cosp*nscol_cosp) ! CAM frac_out (time,height_mlev,column,profile) + real(r8) :: scops_out(pcols,nlay*nscol_cosp) ! CAM frac_out (time,height_mlev,column,profile) real(r8) :: cltmodis(pcols) real(r8) :: clwmodis(pcols) real(r8) :: climodis(pcols) @@ -1545,8 +1442,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8) :: clrimodis(pcols,ntau_cosp,numMODISReffIceBins) real(r8) :: clrlmodis_cam(pcols,ntau_cosp*numMODISReffLiqBins) real(r8) :: clrlmodis(pcols,ntau_cosp,numMODISReffLiqBins) - !real(r8) :: tau067_out(pcols,nhtml_cosp*nscol_cosp),emis11_out(pcols,nhtml_cosp*nscol_cosp) - real(r8),dimension(pcols,nhtml_cosp*nscol_cosp) :: & + real(r8),dimension(pcols,nlay*nscol_cosp) :: & tau067_out,emis11_out,fracliq_out,cal_betatot,cal_betatot_ice, & cal_betatot_liq,cal_tautot,cal_tautot_ice,cal_tautot_liq,cs_gvol_out,cs_krvol_out,cs_zvol_out,& asym34_out,ssa34_out @@ -1580,10 +1476,10 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn clisccp2(1:pcols,1:ntau_cosp,1:nprs_cosp) = R_UNDEF cfad_dbze94(1:pcols,1:CLOUDSAT_DBZE_BINS,1:nht_cosp) = R_UNDEF cfad_lidarsr532(1:pcols,1:nsr_cosp,1:nht_cosp)= R_UNDEF - dbze94(1:pcols,1:nscol_cosp,1:nhtml_cosp) = R_UNDEF - atb532(1:pcols,1:nscol_cosp,1:nhtml_cosp) = R_UNDEF + dbze94(1:pcols,1:nscol_cosp,1:nlay) = R_UNDEF + atb532(1:pcols,1:nscol_cosp,1:nlay) = R_UNDEF clMISR(1:pcols,ntau_cosp,1:nhtmisr_cosp) = R_UNDEF - frac_out(1:pcols,1:nscol_cosp,1:nhtml_cosp) = R_UNDEF + frac_out(1:pcols,1:nscol_cosp,1:nlay) = R_UNDEF ! (all CAM output variables. including collapsed variables) cldtot_isccp(1:pcols) = R_UNDEF @@ -1613,22 +1509,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn cld_cal_tmpliq(1:pcols,1:nht_cosp) = R_UNDEF cld_cal_tmpice(1:pcols,1:nht_cosp) = R_UNDEF cld_cal_tmpun(1:pcols,1:nht_cosp) = R_UNDEF -! cldopaq_cal(1:pcols) = R_UNDEF -! cldthin_cal(1:pcols) = R_UNDEF -! cldopaqz_cal(1:pcols) = R_UNDEF -! cldopaq_cal_temp(1:pcols) = R_UNDEF -! cldthin_cal_temp(1:pcols) = R_UNDEF -! cldzopaq_cal_temp(1:pcols) = R_UNDEF -! cldopaq_cal_z(1:pcols) = R_UNDEF -! cldthin_cal_z(1:pcols) = R_UNDEF -! cldthin_cal_emis(1:pcols) = R_UNDEF -! cldopaq_cal_se(1:pcols) = R_UNDEF -! cldthin_cal_se(1:pcols) = R_UNDEF -! cldzopaq_cal_se(1:pcols) = R_UNDEF -! cldopaq_cal_2d(1:pcols,1:nht_cosp) = R_UNDEF -! cldthin_cal_2d(1:pcols,1:nht_cosp) = R_UNDEF -! cldzopaq_cal_2d(1:pcols,1:nht_cosp) = R_UNDEF -! opacity_cal_2d(1:pcols,1:nht_cosp) = R_UNDEF cfad_dbze94_cs(1:pcols,1:nht_cosp*CLOUDSAT_DBZE_BINS) = R_UNDEF cfad_sr532_cal(1:pcols,1:nht_cosp*nsr_cosp) = R_UNDEF tau_isccp(1:pcols,1:nscol_cosp) = R_UNDEF @@ -1636,7 +1516,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn meantau_isccp(1:pcols) = R_UNDEF meantb_isccp(1:pcols) = R_UNDEF meantbclr_isccp(1:pcols) = R_UNDEF - dbze_cs(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF + dbze_cs(1:pcols,1:nlay*nscol_cosp) = R_UNDEF ptcloudsatflag0(1:pcols) = R_UNDEF ptcloudsatflag1(1:pcols) = R_UNDEF ptcloudsatflag2(1:pcols) = R_UNDEF @@ -1652,11 +1532,11 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn cldtot_cs(1:pcols) = R_UNDEF cldtot_cs2(1:pcols) = R_UNDEF cld_cal_notcs(1:pcols,1:nht_cosp) = R_UNDEF - atb532_cal(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF - mol532_cal(1:pcols,1:nhtml_cosp) = R_UNDEF + atb532_cal(1:pcols,1:nlay*nscol_cosp) = R_UNDEF + mol532_cal(1:pcols,1:nlay) = R_UNDEF cld_misr(1:pcols,1:nhtmisr_cosp*ntau_cosp) = R_UNDEF refl_parasol(1:pcols,1:nsza_cosp) = R_UNDEF - scops_out(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF + scops_out(1:pcols,1:nlay*nscol_cosp) = R_UNDEF cltmodis(1:pcols) = R_UNDEF clwmodis(1:pcols) = R_UNDEF climodis(1:pcols) = R_UNDEF @@ -1680,11 +1560,11 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn clrimodis(1:pcols,1:ntau_cosp_modis,1:numMODISReffIceBins) = R_UNDEF ! +cosp2 clrlmodis_cam(1:pcols,1:ntau_cosp_modis*numMODISReffLiqBins) = R_UNDEF ! +cosp2 clrlmodis(1:pcols,1:ntau_cosp_modis,1:numMODISReffLiqBins) = R_UNDEF ! +cosp2 - tau067_out(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF ! +cosp2 - emis11_out(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF ! +cosp2 - asym34_out(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF ! +cosp2 - ssa34_out(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF ! +cosp2 - fracLiq_out(1:pcols,1:nhtml_cosp*nscol_cosp) = R_UNDEF ! +cosp2 + tau067_out(1:pcols,1:nlay*nscol_cosp) = R_UNDEF ! +cosp2 + emis11_out(1:pcols,1:nlay*nscol_cosp) = R_UNDEF ! +cosp2 + asym34_out(1:pcols,1:nlay*nscol_cosp) = R_UNDEF ! +cosp2 + ssa34_out(1:pcols,1:nlay*nscol_cosp) = R_UNDEF ! +cosp2 + fracLiq_out(1:pcols,1:nlay*nscol_cosp) = R_UNDEF ! +cosp2 ! ###################################################################################### ! DECIDE WHICH COLUMNS YOU ARE GOING TO RUN COSP ON.... @@ -1766,7 +1646,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn call cnst_get_ind(cnst_names(2),ixcldice) Npoints = ncol ! default is running all columns in the chunk, not pcols = maximum number - Nlevels = pver ! 2) cam_in variables (see camsrfexch.F90) ! I can reference these as is, e.g., cam_in%ts. @@ -1903,9 +1782,8 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn snow_cv(1:ncol,1:pverp) = 0._r8 rain_cv_interp(1:ncol,1:pver) = 0._r8 snow_cv_interp(1:ncol,1:pver) = 0._r8 - reff_cosp(1:ncol,1:pver,1:nhydro) = 0._r8 - ! note: reff_cosp dimensions should be same as cosp (reff_cosp has 9 hydrometeor dimension) - ! Reff(Npoints,Nlevels,N_HYDRO) + reff_cosp(1:ncol,1:pver,1:nhydro) = 0._r8 ! reff_cosp dimensions should be same as cosp + ! (reff_cosp has 9 hydrometeor dimension) use_precipitation_fluxes = .true. !!! consistent with cam4 implementation. @@ -2156,7 +2034,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! 3D outputs, but first compress to 2D do i=1,ncol - do ihml=1,nhtml_cosp + do ihml=1,nlay do isc=1,nscol_cosp ihsc = (ihml-1)*nscol_cosp+isc tau067_out(i,ihsc) = cospIN%tau_067(i,isc,ihml) @@ -2268,12 +2146,12 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! ###################################################################################### call t_startf("output_copying") if (allocated(cospIN%frac_out)) & - frac_out(1:ncol,1:nscol_cosp,1:nhtml_cosp) = cospIN%frac_out ! frac_out (time,height_mlev,column,profile) + frac_out(1:ncol,1:nscol_cosp,1:nlay) = cospIN%frac_out ! frac_out (time,height_mlev,column,profile) ! Cloudsat if (lradar_sim) then cfad_dbze94(1:ncol,1:CLOUDSAT_DBZE_BINS,1:nht_cosp) = cospOUT%cloudsat_cfad_ze ! cfad_dbze94 (time,height,dbze,profile) - dbze94(1:ncol,1:nscol_cosp,1:nhtml_cosp) = cospOUT%cloudsat_Ze_tot ! dbze94 (time,height_mlev,column,profile) + dbze94(1:ncol,1:nscol_cosp,1:nlay) = cospOUT%cloudsat_Ze_tot ! dbze94 (time,height_mlev,column,profile) cldtot_cs(1:ncol) = 0._r8!cospOUT%cloudsat_radar_tcc ! CAM version of cltradar (time,profile) ! NOT COMPUTED IN COSP2 cldtot_cs2(1:ncol) = 0._r8!cospOUT%cloudsat_radar_tcc2 ! CAM version of cltradar2 (time,profile) ! NOT COMPUTED IN COSP2 ! *NOTE* These two fields are joint-simulator products, but in CAM they are controlled @@ -2329,28 +2207,11 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn cld_cal_tmpice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,3) ! CAM version of clcalipsotmpliq cld_cal_tmpun(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,4) ! CAM version of clcalipsotmpun, !+cosp1.4 cld_cal(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcld(:,1:nht_cosp) ! CAM version of clcalipso (time,height,profile) - mol532_cal(1:ncol,1:nhtml_cosp) = cospOUT%calipso_beta_mol ! CAM version of beta_mol532 (time,height_mlev,profile) - atb532(1:ncol,1:nscol_cosp,1:nhtml_cosp) = cospOUT%calipso_beta_tot ! atb532 (time,height_mlev,column,profile) + mol532_cal(1:ncol,1:nlay) = cospOUT%calipso_beta_mol ! CAM version of beta_mol532 (time,height_mlev,profile) + atb532(1:ncol,1:nscol_cosp,1:nlay)= cospOUT%calipso_beta_tot ! atb532 (time,height_mlev,column,profile) cfad_lidarsr532(1:ncol,1:nsr_cosp,1:nht_cosp) = cospOUT%calipso_cfad_sr(:,:,:) ! cfad_lidarsr532 (time,height,scat_ratio,profile) ! PARASOL. In COSP2, the Parasol simulator is independent of the calipso simulator. refl_parasol(1:ncol,1:nsza_cosp) = cospOUT%parasolGrid_refl ! CAM version of parasolrefl (time,sza,profile) - ! CALIPSO Opaque cloud diagnostics -! cldopaq_cal(1:pcols) = cospOUT%calipso_cldtype(:,1) -! cldthin_cal(1:pcols) = cospOUT%calipso_cldtype(:,2) -! cldopaqz_cal(1:pcols) = cospOUT%calipso_cldtype(:,3) -! cldopaq_cal_temp(1:pcols) = cospOUT%calipso_cldtypetemp(:,1) -! cldthin_cal_temp(1:pcols) = cospOUT%calipso_cldtypetemp(:,2) -! cldzopaq_cal_temp(1:pcols) = cospOUT%calipso_cldtypetemp(:,3) -! cldopaq_cal_z(1:pcols) = cospOUT%calipso_cldtypemeanz(:,1) -! cldthin_cal_z(1:pcols) = cospOUT%calipso_cldtypemeanz(:,2) -! cldthin_cal_emis(1:pcols) = cospOUT%calipso_cldthinemis -! cldopaq_cal_se(1:pcols) = cospOUT%calipso_cldtypemeanzse(:,1) -! cldthin_cal_se(1:pcols) = cospOUT%calipso_cldtypemeanzse(:,2) -! cldzopaq_cal_se(1:pcols) = cospOUT%calipso_cldtypemeanzse(:,3) -! cldopaq_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,1) -! cldthin_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,2) -! cldzopaq_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,3) -! opacity_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,4) endif ! ISCCP @@ -2408,7 +2269,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn end do end do ! CAM dbze94 (time,height_mlev,column,profile) - do ihml=1,nhtml_cosp + do ihml=1,nlay do isc=1,nscol_cosp ihsc=(ihml-1)*nscol_cosp+isc dbze_cs(i,ihsc) = dbze94(i,isc,ihml) ! dbze_cs(pcols,pver*nscol_cosp) @@ -2425,7 +2286,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn end do end do ! CAM atb532 (time,height_mlev,column,profile) FIX - do ihml=1,nhtml_cosp + do ihml=1,nlay do isc=1,nscol_cosp ihsc=(ihml-1)*nscol_cosp+isc atb532_cal(i,ihsc) = atb532(i,isc,ihml) ! atb532_cal(pcols,nht_cosp*nscol_cosp) @@ -2468,7 +2329,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn endif ! Subcolums - do ihml=1,nhtml_cosp + do ihml=1,nlay do isc=1,nscol_cosp ihsc=(ihml-1)*nscol_cosp+isc scops_out(i,ihsc) = frac_out(i,isc,ihml) ! scops_out(pcols,nht_cosp*nscol_cosp) diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index a439f84423..ba9fc57fdf 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -150,7 +150,6 @@ subroutine phys_register use aircraft_emit, only: aircraft_emit_register use cam_diagnostics, only: diag_register use cloud_diagnostics, only: cloud_diagnostics_register - use cospsimulator_intr, only: cospsimulator_intr_register use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not use radheat, only: radheat_register use subcol, only: subcol_register @@ -326,9 +325,6 @@ subroutine phys_register call cloud_diagnostics_register call radheat_register - ! COSP - call cospsimulator_intr_register - ! vertical diffusion call vd_register() else From 3b235e40241456c21ba56abff774e41ae68c1d42 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 3 Apr 2024 19:47:48 -0400 Subject: [PATCH 02/17] mods to limit COSP top --- src/physics/cam/cospsimulator_intr.F90 | 1568 ++++++++++-------------- 1 file changed, 630 insertions(+), 938 deletions(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index cb2246962d..0606d696b2 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -21,7 +21,7 @@ module cospsimulator_intr #ifdef USE_COSP use quickbeam, only: radar_cfg use mod_quickbeam_optics, only: size_distribution - use mod_cosp, only: cosp_outputs,cosp_optical_inputs,cosp_column_inputs + use mod_cosp, only: cosp_outputs, cosp_optical_inputs, cosp_column_inputs use mod_cosp_config, only: pres_binCenters, pres_binEdges, tau_binCenters, & tau_binEdges, cloudsat_binCenters, cloudsat_binEdges, calipso_binCenters, & calipso_binEdges, misr_histHgtCenters, misr_histHgtEdges, PARASOL_SZA, & @@ -68,6 +68,7 @@ module cospsimulator_intr ! ###################################################################################### integer :: & nlay, & ! Number of CAM layers used by COSP. + nlayp, & ! Number of CAM layer interfaces used by COSP. nscol_cosp, & ! Number of subcolumns, allow namelist input to set. nht_cosp ! Number of height for COSP radar and calipso simulator outputs. ! *set to 40 if csat_vgrid=.true., else set to Nlr* @@ -450,6 +451,7 @@ subroutine cospsimulator_intr_init() ! Set number of levels used by COSP to the number of levels used by ! CAM's cloud macro/microphysics parameterizations. nlay = pver - ktop + 1 + nlayp = nlay + 1 ! COSP initialization call setcosp2values() @@ -473,7 +475,7 @@ subroutine cospsimulator_intr_init() if (llidar_sim .or. lradar_sim) then call add_hist_coord('cosp_ht', nht_cosp, & - 'COSP Mean Height for calipso and radar simulator outputs', 'm', & + 'COSP Mean Height for calipso and radar simulator outputs', 'm', & htmid_cosp, bounds_name='cosp_ht_bnds', bounds=htlim_cosp, & vertical_coord=.true.) end if @@ -490,7 +492,7 @@ subroutine cospsimulator_intr_init() end if if (lradar_sim) then - call add_hist_coord('cosp_dbze', CLOUDSAT_DBZE_BINS, & + call add_hist_coord('cosp_dbze', CLOUDSAT_DBZE_BINS, & 'COSP Mean dBZe for radar simulator CFAD output', 'dBZ', & dbzemid_cosp, bounds_name='cosp_dbze_bnds', bounds=dbzelim_cosp) end if @@ -515,410 +517,351 @@ subroutine cospsimulator_intr_init() ! ISCCP OUTPUTS if (lisccp_sim) then - !! addfld calls for all - !*cfMon,cfDa* clisccp2 (time,tau,plev,profile), CFMIP wants 7 p bins, 7 tau bins - call addfld('FISCCP1_COSP',(/'cosp_tau','cosp_prs'/),'A','percent', & - 'Grid-box fraction covered by each ISCCP D level cloud type',& - flag_xyfill=.true., fill_value=R_UNDEF) - - !*cfMon,cfDa* tclisccp (time,profile), CFMIP wants "gridbox mean cloud cover from ISCCP" - call addfld('CLDTOT_ISCCP', horiz_only,'A','percent', & + call addfld('FISCCP1_COSP', (/'cosp_tau','cosp_prs'/), 'A', 'percent', & + 'Grid-box fraction covered by each ISCCP D level cloud type', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_ISCCP', horiz_only, 'A', 'percent', & 'Total Cloud Fraction Calculated by the ISCCP Simulator ',flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfDa* albisccp (time,profile) - ! Per CFMIP request - weight by ISCCP Total Cloud Fraction (divide by CLDTOT_ISSCP in history file to get weighted average) - call addfld('MEANCLDALB_ISCCP',horiz_only,'A','1','Mean cloud albedo*CLDTOT_ISCCP',flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfDa* ctpisccp (time,profile) - ! Per CFMIP request - weight by ISCCP Total Cloud Fraction (divide by CLDTOT_ISSCP in history file to get weighted average) - call addfld('MEANPTOP_ISCCP',horiz_only,'A','Pa','Mean cloud top pressure*CLDTOT_ISCCP',flag_xyfill=.true., & - fill_value=R_UNDEF) - ! tauisccp (time,profile) - ! For averaging, weight by ISCCP Total Cloud Fraction (divide by CLDTOT_ISSCP in history file to get weighted average) - call addfld ('MEANTAU_ISCCP',horiz_only,'A','1','Mean optical thickness*CLDTOT_ISCCP',flag_xyfill=.true., & - fill_value=R_UNDEF) - ! meantbisccp (time,profile), at 10.5 um - call addfld ('MEANTB_ISCCP',horiz_only,'A','K','Mean Infrared Tb from ISCCP simulator',flag_xyfill=.true., & - fill_value=R_UNDEF) - ! meantbclrisccp (time,profile) - call addfld ('MEANTBCLR_ISCCP',horiz_only,'A','K','Mean Clear-sky Infrared Tb from ISCCP simulator', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! boxtauisccp (time,column,profile) - call addfld ('TAU_ISCCP',(/'cosp_scol'/),'I','1','Optical Depth in each Subcolumn',flag_xyfill=.true., fill_value=R_UNDEF) - ! boxptopisccp (time,column,profile) - call addfld ('CLDPTOP_ISCCP',(/'cosp_scol'/),'I','Pa','Cloud Top Pressure in each Subcolumn', & - flag_xyfill=.true., fill_value=R_UNDEF) - - !! add all isccp outputs to the history file specified by the CAM namelist variable cosp_histfile_num - call add_default ('FISCCP1_COSP',cosp_histfile_num,' ') - call add_default ('CLDTOT_ISCCP',cosp_histfile_num,' ') - call add_default ('MEANCLDALB_ISCCP',cosp_histfile_num,' ') - call add_default ('MEANPTOP_ISCCP',cosp_histfile_num,' ') - call add_default ('MEANTAU_ISCCP',cosp_histfile_num,' ') - call add_default ('MEANTB_ISCCP',cosp_histfile_num,' ') - call add_default ('MEANTBCLR_ISCCP',cosp_histfile_num,' ') + call addfld('MEANCLDALB_ISCCP', horiz_only, 'A', '1', & + 'Mean cloud albedo*CLDTOT_ISCCP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('MEANPTOP_ISCCP', horiz_only, 'A', 'Pa', & + 'Mean cloud top pressure*CLDTOT_ISCCP',flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('MEANTAU_ISCCP', horiz_only, 'A', '1', & + 'Mean optical thickness*CLDTOT_ISCCP',flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('MEANTB_ISCCP', horiz_only, 'A', 'K', & + 'Mean Infrared Tb from ISCCP simulator',flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('MEANTBCLR_ISCCP', horiz_only, 'A', 'K', & + 'Mean Clear-sky Infrared Tb from ISCCP simulator', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAU_ISCCP', (/'cosp_scol'/), 'I', '1', & + 'Optical Depth in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDPTOP_ISCCP', (/'cosp_scol'/), 'I', 'Pa', & + 'Cloud Top Pressure in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) + + call add_default('FISCCP1_COSP',cosp_histfile_num,' ') + call add_default('CLDTOT_ISCCP',cosp_histfile_num,' ') + call add_default('MEANCLDALB_ISCCP',cosp_histfile_num,' ') + call add_default('MEANPTOP_ISCCP',cosp_histfile_num,' ') + call add_default('MEANTAU_ISCCP',cosp_histfile_num,' ') + call add_default('MEANTB_ISCCP',cosp_histfile_num,' ') + call add_default('MEANTBCLR_ISCCP',cosp_histfile_num,' ') end if ! CALIPSO SIMULATOR OUTPUTS if (llidar_sim) then - !! addfld calls for all - !*cfMon,cfOff,cfDa,cf3hr* cllcalipso (time,profile) - call addfld('CLDLOW_CAL',horiz_only,'A','percent','Calipso Low-level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfOff,cfDa,cf3hr* clmcalipso (time,profile) - call addfld('CLDMED_CAL',horiz_only,'A','percent','Calipso Mid-level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfOff,cfDa,cf3hr* clhcalipso (time,profile) - call addfld('CLDHGH_CAL',horiz_only,'A','percent','Calipso High-level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfOff,cfDa,cf3hr* cltcalipso (time,profile) - call addfld('CLDTOT_CAL',horiz_only,'A','percent','Calipso Total Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfOff,cfDa,cf3hr* clcalipso (time,height,profile) - call addfld('CLD_CAL',(/'cosp_ht'/),'A','percent','Calipso Cloud Fraction (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF) - !*cfMon,cfOff,cfDa,cf3hr* parasol_refl (time,sza,profile) - call addfld ('RFL_PARASOL',(/'cosp_sza'/),'A','fraction','PARASOL-like mono-directional reflectance ', & - flag_xyfill=.true., fill_value=R_UNDEF) - !*cfOff,cf3hr* cfad_calipsosr532 (time,height,scat_ratio,profile), %11%, default is 40 vert levs, 15 SR bins - call addfld('CFAD_SR532_CAL',(/'cosp_sr','cosp_ht'/),'A','fraction', & - 'Calipso Scattering Ratio CFAD (532 nm)', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! beta_mol532 (time,height_mlev,profile) - call addfld ('MOL532_CAL',(/'lev'/),'A','m-1sr-1','Calipso Molecular Backscatter (532 nm) ', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! atb532 (time,height_mlev,column,profile) - call addfld ('ATB532_CAL',(/'cosp_scol','lev '/),'I','no_unit_log10(x)', & - 'Calipso Attenuated Total Backscatter (532 nm) in each Subcolumn', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsoliq (time,alt40,loc) !!+cosp1.4 - call addfld('CLD_CAL_LIQ', (/'cosp_ht'/), 'A','percent', 'Calipso Liquid Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsoice (time,alt40,loc) - call addfld('CLD_CAL_ICE', (/'cosp_ht'/), 'A','percent', 'Calipso Ice Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsoun (time,alt40,loc) - call addfld('CLD_CAL_UN', (/'cosp_ht'/),'A','percent', 'Calipso Undefined-Phase Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsotmp (time,alt40,loc) - call addfld('CLD_CAL_TMP', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsotmpliq (time,alt40,loc) - call addfld('CLD_CAL_TMPLIQ', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsotmpice (time,alt40,loc) - call addfld('CLD_CAL_TMPICE', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclcalipsotmpun (time,alt40,loc) - call addfld('CLD_CAL_TMPUN', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lcltcalipsoice (time,loc) - call addfld('CLDTOT_CAL_ICE', horiz_only,'A','percent','Calipso Total Ice Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lcltcalipsoliq (time,loc) - call addfld('CLDTOT_CAL_LIQ', horiz_only,'A','percent','Calipso Total Liquid Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lcltcalipsoun (time,loc) - call addfld('CLDTOT_CAL_UN',horiz_only,'A','percent','Calipso Total Undefined-Phase Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclhcalipsoice (time,loc) - call addfld('CLDHGH_CAL_ICE',horiz_only,'A','percent','Calipso High-level Ice Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclhcalipsoliq (time,loc) - call addfld('CLDHGH_CAL_LIQ',horiz_only,'A','percent','Calipso High-level Liquid Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclhcalipsoun (time,loc) - call addfld('CLDHGH_CAL_UN',horiz_only,'A','percent','Calipso High-level Undefined-Phase Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclmcalipsoice (time,loc) - call addfld('CLDMED_CAL_ICE',horiz_only,'A','percent','Calipso Mid-level Ice Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclmcalipsoliq (time,loc) - call addfld('CLDMED_CAL_LIQ',horiz_only,'A','percent','Calipso Mid-level Liquid Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lclmcalipsoun (time,loc) - call addfld('CLDMED_CAL_UN',horiz_only,'A','percent','Calipso Mid-level Undefined-Phase Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lcllcalipsoice (time,loc) - call addfld('CLDLOW_CAL_ICE',horiz_only,'A','percent','Calipso Low-level Ice Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lcllcalipsoliq (time,loc) - call addfld('CLDLOW_CAL_LIQ',horiz_only,'A','percent','Calipso Low-level Liquid Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! lcllcalipsoun (time,loc) !+cosp1.4 - call addfld('CLDLOW_CAL_UN',horiz_only,'A','percent','Calipso Low-level Undefined-Phase Cloud Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - - ! add_default calls for CFMIP experiments or else all fields are added to history file - ! except those with sub-column dimension/experimental variables - !! add all calipso outputs to the history file specified by the CAM namelist variable cosp_histfile_num - call add_default ('CLDLOW_CAL',cosp_histfile_num,' ') - call add_default ('CLDMED_CAL',cosp_histfile_num,' ') - call add_default ('CLDHGH_CAL',cosp_histfile_num,' ') - call add_default ('CLDTOT_CAL',cosp_histfile_num,' ') - call add_default ('CLD_CAL',cosp_histfile_num,' ') - call add_default ('RFL_PARASOL',cosp_histfile_num,' ') - call add_default ('CFAD_SR532_CAL',cosp_histfile_num,' ') - call add_default ('CLD_CAL_LIQ',cosp_histfile_num,' ') !+COSP1.4 - call add_default ('CLD_CAL_ICE',cosp_histfile_num,' ') - call add_default ('CLD_CAL_UN',cosp_histfile_num,' ') - call add_default ('CLDTOT_CAL_ICE',cosp_histfile_num,' ') - call add_default ('CLDTOT_CAL_LIQ',cosp_histfile_num,' ') - call add_default ('CLDTOT_CAL_UN',cosp_histfile_num,' ') - call add_default ('CLDHGH_CAL_ICE',cosp_histfile_num,' ') - call add_default ('CLDHGH_CAL_LIQ',cosp_histfile_num,' ') - call add_default ('CLDHGH_CAL_UN',cosp_histfile_num,' ') - call add_default ('CLDMED_CAL_ICE',cosp_histfile_num,' ') - call add_default ('CLDMED_CAL_LIQ',cosp_histfile_num,' ') - call add_default ('CLDMED_CAL_UN',cosp_histfile_num,' ') - call add_default ('CLDLOW_CAL_ICE',cosp_histfile_num,' ') - call add_default ('CLDLOW_CAL_LIQ',cosp_histfile_num,' ') - call add_default ('CLDLOW_CAL_UN',cosp_histfile_num,' ') + call addfld('CLDLOW_CAL', horiz_only, 'A', 'percent', & + 'Calipso Low-level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDMED_CAL', horiz_only, 'A', 'percent', & + 'Calipso Mid-level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDHGH_CAL', horiz_only, 'A', 'percent', & + 'Calipso High-level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CAL', horiz_only, 'A', 'percent', & + 'Calipso Total Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL', (/'cosp_ht'/), 'A', 'percent', & + 'Calipso Cloud Fraction (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('RFL_PARASOL', (/'cosp_sza'/), 'A', 'fraction', & + 'PARASOL-like mono-directional reflectance ', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CFAD_SR532_CAL', (/'cosp_sr','cosp_ht'/), 'A', 'fraction', & + 'Calipso Scattering Ratio CFAD (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('MOL532_CAL', (/'lev'/), 'A', 'm-1sr-1', & + 'Calipso Molecular Backscatter (532 nm) ', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('ATB532_CAL', (/'cosp_scol','lev '/), 'I', 'no_unit_log10(x)', & + 'Calipso Attenuated Total Backscatter (532 nm) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_LIQ', (/'cosp_ht'/), 'A', 'percent', & + 'Calipso Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_ICE', (/'cosp_ht'/), 'A', 'percent', & + 'Calipso Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_UN', (/'cosp_ht'/), 'A', 'percent', & + 'Calipso Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMP', (/'cosp_ht'/), 'A', 'percent', & + 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMPLIQ', (/'cosp_ht'/), 'A', 'percent', & + 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMPICE', (/'cosp_ht'/), 'A', 'percent', & + 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMPUN', (/'cosp_ht'/), 'A', 'percent', & + 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CAL_ICE', horiz_only, 'A', 'percent', & + 'Calipso Total Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CAL_LIQ', horiz_only, 'A', 'percent', & + 'Calipso Total Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CAL_UN', horiz_only, 'A', 'percent', & + 'Calipso Total Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDHGH_CAL_ICE', horiz_only, 'A', 'percent', & + 'Calipso High-level Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDHGH_CAL_LIQ', horiz_only, 'A', 'percent', & + 'Calipso High-level Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDHGH_CAL_UN', horiz_only, 'A', 'percent', & + 'Calipso High-level Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDMED_CAL_ICE', horiz_only, 'A', 'percent', & + 'Calipso Mid-level Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDMED_CAL_LIQ', horiz_only, 'A', 'percent', & + 'Calipso Mid-level Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDMED_CAL_UN', horiz_only, 'A', 'percent', & + 'Calipso Mid-level Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDLOW_CAL_ICE', horiz_only, 'A', 'percent', & + 'Calipso Low-level Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDLOW_CAL_LIQ', horiz_only, 'A', 'percent', & + 'Calipso Low-level Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDLOW_CAL_UN', horiz_only, 'A', 'percent', & + 'Calipso Low-level Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + + call add_default('CLDLOW_CAL',cosp_histfile_num,' ') + call add_default('CLDMED_CAL',cosp_histfile_num,' ') + call add_default('CLDHGH_CAL',cosp_histfile_num,' ') + call add_default('CLDTOT_CAL',cosp_histfile_num,' ') + call add_default('CLD_CAL',cosp_histfile_num,' ') + call add_default('RFL_PARASOL',cosp_histfile_num,' ') + call add_default('CFAD_SR532_CAL',cosp_histfile_num,' ') + call add_default('CLD_CAL_LIQ',cosp_histfile_num,' ') + call add_default('CLD_CAL_ICE',cosp_histfile_num,' ') + call add_default('CLD_CAL_UN',cosp_histfile_num,' ') + call add_default('CLDTOT_CAL_ICE',cosp_histfile_num,' ') + call add_default('CLDTOT_CAL_LIQ',cosp_histfile_num,' ') + call add_default('CLDTOT_CAL_UN',cosp_histfile_num,' ') + call add_default('CLDHGH_CAL_ICE',cosp_histfile_num,' ') + call add_default('CLDHGH_CAL_LIQ',cosp_histfile_num,' ') + call add_default('CLDHGH_CAL_UN',cosp_histfile_num,' ') + call add_default('CLDMED_CAL_ICE',cosp_histfile_num,' ') + call add_default('CLDMED_CAL_LIQ',cosp_histfile_num,' ') + call add_default('CLDMED_CAL_UN',cosp_histfile_num,' ') + call add_default('CLDLOW_CAL_ICE',cosp_histfile_num,' ') + call add_default('CLDLOW_CAL_LIQ',cosp_histfile_num,' ') + call add_default('CLDLOW_CAL_UN',cosp_histfile_num,' ') if ((.not.cosp_amwg) .and. (.not.cosp_lite) .and. (.not.cosp_passive) .and. (.not.cosp_active) & .and. (.not.cosp_isccp)) then - call add_default ('MOL532_CAL',cosp_histfile_num,' ') + call add_default('MOL532_CAL',cosp_histfile_num,' ') end if end if ! RADAR SIMULATOR OUTPUTS + allocate(sd_cs(begchunk:endchunk), rcfg_cs(begchunk:endchunk)) if (lradar_sim) then - allocate(sd_cs(begchunk:endchunk), rcfg_cs(begchunk:endchunk)) do i = begchunk, endchunk sd_cs(i) = sd rcfg_cs(i) = rcfg_cloudsat end do - ! addfld calls - !*cfOff,cf3hr* cfad_dbze94 (time,height,dbze,profile), default is 40 vert levs, 15 dBZ bins - call addfld('CFAD_DBZE94_CS',(/'cosp_dbze','cosp_ht '/),'A','fraction',& - 'Radar Reflectivity Factor CFAD (94 GHz)',& - flag_xyfill=.true., fill_value=R_UNDEF) - !*cfOff,cf3hr* clcalipso2 (time,height,profile) - call addfld ('CLD_CAL_NOTCS',(/'cosp_ht'/),'A','percent','Cloud occurrence seen by CALIPSO but not CloudSat ', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! cltcalipsoradar (time,profile) - call addfld ('CLDTOT_CALCS',horiz_only,'A','percent',' Calipso and Radar Total Cloud Fraction ',flag_xyfill=.true., & - fill_value=R_UNDEF) - call addfld ('CLDTOT_CS',horiz_only,'A','percent',' Radar total cloud amount ',flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CLDTOT_CS2',horiz_only,'A','percent', & - ' Radar total cloud amount without the data for the first kilometer above surface ', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! dbze94 (time,height_mlev,column,profile),! height_mlevel = height when vgrid_in = .true. (default) - call addfld ('DBZE_CS',(/'cosp_scol','lev '/),'I','dBZe',' Radar dBZe (94 GHz) in each Subcolumn',& + call addfld('CFAD_DBZE94_CS',(/'cosp_dbze','cosp_ht '/), 'A', 'fraction', & + 'Radar Reflectivity Factor CFAD (94 GHz)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_NOTCS', (/'cosp_ht'/), 'A', 'percent', & + 'Cloud occurrence seen by CALIPSO but not CloudSat ', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CALCS', horiz_only, 'A', 'percent', & + 'Calipso and Radar Total Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CS', horiz_only, 'A', 'percent', & + 'Radar total cloud amount', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLDTOT_CS2', horiz_only, 'A', 'percent', & + 'Radar total cloud amount without the data for the first kilometer above surface ', & flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('DBZE_CS', (/'cosp_scol','lev '/), 'I', 'dBZe', & + 'Radar dBZe (94 GHz) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) ! Cloudsat near-sfc precipitation diagnostics - call addfld('CS_NOPRECIP', horiz_only, 'A', '1', 'CloudSat No Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_RAINPOSS', horiz_only, 'A', '1', 'Cloudsat Rain Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_RAINPROB', horiz_only, 'A', '1', 'CloudSat Rain Probable Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_RAINCERT', horiz_only, 'A', '1', 'CloudSat Rain Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_SNOWPOSS', horiz_only, 'A', '1', 'CloudSat Snow Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_SNOWCERT', horiz_only, 'A', '1', 'CloudSat Snow Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_MIXPOSS', horiz_only, 'A', '1', 'CloudSat Mixed Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_MIXCERT', horiz_only, 'A', '1', 'CloudSat Mixed Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_RAINHARD', horiz_only, 'A', '1', 'CloudSat Heavy Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_UN', horiz_only, 'A', '1', 'CloudSat Unclassified Precipitation Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CS_PIA', horiz_only, 'A', 'dBZ', 'CloudSat Radar Path Integrated Attenuation', flag_xyfill=.true., fill_value=R_UNDEF) - - ! add_default calls for CFMIP experiments or else all fields are added to history file except those with sub-column dimension - !! add all radar outputs to the history file specified by the CAM namelist variable cosp_histfile_num - call add_default ('CFAD_DBZE94_CS',cosp_histfile_num,' ') - call add_default ('CLD_CAL_NOTCS', cosp_histfile_num,' ') - call add_default ('CLDTOT_CALCS', cosp_histfile_num,' ') - call add_default ('CLDTOT_CS', cosp_histfile_num,' ') - call add_default ('CLDTOT_CS2', cosp_histfile_num,' ') - call add_default ('CS_NOPRECIP', cosp_histfile_num,' ') - call add_default ('CS_RAINPOSS', cosp_histfile_num,' ') - call add_default ('CS_RAINPROB', cosp_histfile_num,' ') - call add_default ('CS_RAINCERT', cosp_histfile_num,' ') - call add_default ('CS_SNOWPOSS', cosp_histfile_num,' ') - call add_default ('CS_SNOWCERT', cosp_histfile_num,' ') - call add_default ('CS_MIXPOSS', cosp_histfile_num,' ') - call add_default ('CS_MIXCERT', cosp_histfile_num,' ') - call add_default ('CS_RAINHARD', cosp_histfile_num,' ') - call add_default ('CS_UN', cosp_histfile_num,' ') - call add_default ('CS_PIA', cosp_histfile_num,' ') + call addfld('CS_NOPRECIP', horiz_only, 'A', '1', & + 'CloudSat No Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_RAINPOSS', horiz_only, 'A', '1', & + 'Cloudsat Rain Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_RAINPROB', horiz_only, 'A', '1', & + 'CloudSat Rain Probable Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_RAINCERT', horiz_only, 'A', '1', & + 'CloudSat Rain Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_SNOWPOSS', horiz_only, 'A', '1', & + 'CloudSat Snow Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_SNOWCERT', horiz_only, 'A', '1', & + 'CloudSat Snow Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_MIXPOSS', horiz_only, 'A', '1', & + 'CloudSat Mixed Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_MIXCERT', horiz_only, 'A', '1', & + 'CloudSat Mixed Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_RAINHARD', horiz_only, 'A', '1', & + 'CloudSat Heavy Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_UN', horiz_only, 'A', '1', & + 'CloudSat Unclassified Precipitation Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CS_PIA', horiz_only, 'A', 'dBZ', & + 'CloudSat Radar Path Integrated Attenuation', flag_xyfill=.true., fill_value=R_UNDEF) + + call add_default('CFAD_DBZE94_CS',cosp_histfile_num,' ') + call add_default('CLD_CAL_NOTCS', cosp_histfile_num,' ') + call add_default('CLDTOT_CALCS', cosp_histfile_num,' ') + call add_default('CLDTOT_CS', cosp_histfile_num,' ') + call add_default('CLDTOT_CS2', cosp_histfile_num,' ') + call add_default('CS_NOPRECIP', cosp_histfile_num,' ') + call add_default('CS_RAINPOSS', cosp_histfile_num,' ') + call add_default('CS_RAINPROB', cosp_histfile_num,' ') + call add_default('CS_RAINCERT', cosp_histfile_num,' ') + call add_default('CS_SNOWPOSS', cosp_histfile_num,' ') + call add_default('CS_SNOWCERT', cosp_histfile_num,' ') + call add_default('CS_MIXPOSS', cosp_histfile_num,' ') + call add_default('CS_MIXCERT', cosp_histfile_num,' ') + call add_default('CS_RAINHARD', cosp_histfile_num,' ') + call add_default('CS_UN', cosp_histfile_num,' ') + call add_default('CS_PIA', cosp_histfile_num,' ') end if ! MISR SIMULATOR OUTPUTS if (lmisr_sim) then - ! clMISR (time,tau,CTH_height_bin,profile) - call addfld ('CLD_MISR',(/'cosp_tau ','cosp_htmisr'/),'A','percent','Cloud Fraction from MISR Simulator', & - flag_xyfill=.true., fill_value=R_UNDEF) - !! add all misr outputs to the history file specified by the CAM namelist variable cosp_histfile_num - call add_default ('CLD_MISR',cosp_histfile_num,' ') + call addfld('CLD_MISR', (/'cosp_tau ','cosp_htmisr'/), 'A', 'percent', & + 'Cloud Fraction from MISR Simulator', flag_xyfill=.true., fill_value=R_UNDEF) + + call add_default('CLD_MISR',cosp_histfile_num,' ') end if ! MODIS OUTPUT if (lmodis_sim) then - ! float cltmodis ( time, loc ) - call addfld ('CLTMODIS',horiz_only,'A','%','MODIS Total Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - ! float clwmodis ( time, loc ) - call addfld ('CLWMODIS',horiz_only,'A','%','MODIS Liquid Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - ! float climodis ( time, loc ) - call addfld ('CLIMODIS',horiz_only,'A','%','MODIS Ice Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - ! float clhmodis ( time, loc ) - call addfld ('CLHMODIS',horiz_only,'A','%','MODIS High Level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - ! float clmmodis ( time, loc ) - call addfld ('CLMMODIS',horiz_only,'A','%','MODIS Mid Level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - ! float cllmodis ( time, loc ) - call addfld ('CLLMODIS',horiz_only,'A','%','MODIS Low Level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF) - ! float tautmodis ( time, loc ) - call addfld ('TAUTMODIS',horiz_only,'A','1','MODIS Total Cloud Optical Thickness*CLTMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float tauwmodis ( time, loc ) - call addfld ('TAUWMODIS',horiz_only,'A','1','MODIS Liquid Cloud Optical Thickness*CLWMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float tauimodis ( time, loc ) - call addfld ('TAUIMODIS',horiz_only,'A','1','MODIS Ice Cloud Optical Thickness*CLIMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float tautlogmodis ( time, loc ) - call addfld ('TAUTLOGMODIS',horiz_only,'A','1','MODIS Total Cloud Optical Thickness (Log10 Mean)*CLTMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float tauwlogmodis ( time, loc ) - call addfld ('TAUWLOGMODIS',horiz_only,'A','1','MODIS Liquid Cloud Optical Thickness (Log10 Mean)*CLWMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float tauilogmodis ( time, loc ) - call addfld ('TAUILOGMODIS',horiz_only,'A','1','MODIS Ice Cloud Optical Thickness (Log10 Mean)*CLIMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float reffclwmodis ( time, loc ) - call addfld ('REFFCLWMODIS',horiz_only,'A','m','MODIS Liquid Cloud Particle Size*CLWMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float reffclimodis ( time, loc ) - call addfld ('REFFCLIMODIS',horiz_only,'A','m','MODIS Ice Cloud Particle Size*CLIMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float pctmodis ( time, loc ) - call addfld ('PCTMODIS',horiz_only,'A','Pa','MODIS Cloud Top Pressure*CLTMODIS',flag_xyfill=.true., fill_value=R_UNDEF) - ! float lwpmodis ( time, loc ) - call addfld ('LWPMODIS',horiz_only,'A','kg m-2','MODIS Cloud Liquid Water Path*CLWMODIS', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float iwpmodis ( time, loc ) - call addfld ('IWPMODIS',horiz_only,'A','kg m-2','MODIS Cloud Ice Water Path*CLIMODIS',flag_xyfill=.true., fill_value=R_UNDEF) - ! float clmodis ( time, plev, tau, loc ) - call addfld ('CLMODIS',(/'cosp_tau_modis','cosp_prs '/),'A','%','MODIS Cloud Area Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float clrimodis ( time, plev, tau, loc ) - call addfld ('CLRIMODIS',(/'cosp_tau_modis','cosp_reffice '/),'A','%','MODIS Cloud Area Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) - ! float clrlmodis ( time, plev, tau, loc ) - call addfld ('CLRLMODIS',(/'cosp_tau_modis','cosp_reffliq '/),'A','%','MODIS Cloud Area Fraction', & - flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLTMODIS', horiz_only, 'A', '%', & + 'MODIS Total Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLWMODIS', horiz_only, 'A', '%', & + 'MODIS Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLIMODIS', horiz_only, 'A', '%', & + 'MODIS Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLHMODIS', horiz_only, 'A', '%', & + 'MODIS High Level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLMMODIS', horiz_only, 'A', '%', & + 'MODIS Mid Level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLLMODIS', horiz_only, 'A', '%', & + 'MODIS Low Level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAUTMODIS', horiz_only, 'A', '1', & + 'MODIS Total Cloud Optical Thickness*CLTMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAUWMODIS', horiz_only, 'A', '1', & + 'MODIS Liquid Cloud Optical Thickness*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAUIMODIS', horiz_only, 'A', '1', & + 'MODIS Ice Cloud Optical Thickness*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAUTLOGMODIS', horiz_only, 'A', '1', & + 'MODIS Total Cloud Optical Thickness (Log10 Mean)*CLTMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAUWLOGMODIS', horiz_only, 'A', '1', & + 'MODIS Liquid Cloud Optical Thickness (Log10 Mean)*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('TAUILOGMODIS', horiz_only, 'A', '1', & + 'MODIS Ice Cloud Optical Thickness (Log10 Mean)*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('REFFCLWMODIS', horiz_only, 'A', 'm', & + 'MODIS Liquid Cloud Particle Size*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('REFFCLIMODIS', horiz_only, 'A', 'm', & + 'MODIS Ice Cloud Particle Size*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('PCTMODIS', horiz_only, 'A', 'Pa', & + 'MODIS Cloud Top Pressure*CLTMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('LWPMODIS', horiz_only, 'A', 'kg m-2', & + 'MODIS Cloud Liquid Water Path*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('IWPMODIS', horiz_only, 'A', 'kg m-2', & + 'MODIS Cloud Ice Water Path*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLMODIS', (/'cosp_tau_modis','cosp_prs '/), 'A', '%', & + 'MODIS Cloud Area Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLRIMODIS', (/'cosp_tau_modis','cosp_reffice '/), 'A', '%', & + 'MODIS Cloud Area Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLRLMODIS', (/'cosp_tau_modis','cosp_reffliq '/), 'A', '%', & + 'MODIS Cloud Area Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - !! add MODIS output to history file specified by the CAM namelist variable cosp_histfile_num - call add_default ('CLTMODIS',cosp_histfile_num,' ') - call add_default ('CLWMODIS',cosp_histfile_num,' ') - call add_default ('CLIMODIS',cosp_histfile_num,' ') - call add_default ('CLHMODIS',cosp_histfile_num,' ') - call add_default ('CLMMODIS',cosp_histfile_num,' ') - call add_default ('CLLMODIS',cosp_histfile_num,' ') - call add_default ('TAUTMODIS',cosp_histfile_num,' ') - call add_default ('TAUWMODIS',cosp_histfile_num,' ') - call add_default ('TAUIMODIS',cosp_histfile_num,' ') - call add_default ('TAUTLOGMODIS',cosp_histfile_num,' ') - call add_default ('TAUWLOGMODIS',cosp_histfile_num,' ') - call add_default ('TAUILOGMODIS',cosp_histfile_num,' ') - call add_default ('REFFCLWMODIS',cosp_histfile_num,' ') - call add_default ('REFFCLIMODIS',cosp_histfile_num,' ') - call add_default ('PCTMODIS',cosp_histfile_num,' ') - call add_default ('LWPMODIS',cosp_histfile_num,' ') - call add_default ('IWPMODIS',cosp_histfile_num,' ') - call add_default ('CLMODIS',cosp_histfile_num,' ') - call add_default ('CLRIMODIS',cosp_histfile_num,' ') - call add_default ('CLRLMODIS',cosp_histfile_num,' ') + call add_default('CLTMODIS',cosp_histfile_num,' ') + call add_default('CLWMODIS',cosp_histfile_num,' ') + call add_default('CLIMODIS',cosp_histfile_num,' ') + call add_default('CLHMODIS',cosp_histfile_num,' ') + call add_default('CLMMODIS',cosp_histfile_num,' ') + call add_default('CLLMODIS',cosp_histfile_num,' ') + call add_default('TAUTMODIS',cosp_histfile_num,' ') + call add_default('TAUWMODIS',cosp_histfile_num,' ') + call add_default('TAUIMODIS',cosp_histfile_num,' ') + call add_default('TAUTLOGMODIS',cosp_histfile_num,' ') + call add_default('TAUWLOGMODIS',cosp_histfile_num,' ') + call add_default('TAUILOGMODIS',cosp_histfile_num,' ') + call add_default('REFFCLWMODIS',cosp_histfile_num,' ') + call add_default('REFFCLIMODIS',cosp_histfile_num,' ') + call add_default('PCTMODIS',cosp_histfile_num,' ') + call add_default('LWPMODIS',cosp_histfile_num,' ') + call add_default('IWPMODIS',cosp_histfile_num,' ') + call add_default('CLMODIS',cosp_histfile_num,' ') + call add_default('CLRIMODIS',cosp_histfile_num,' ') + call add_default('CLRLMODIS',cosp_histfile_num,' ') end if ! SUB-COLUMN OUTPUT if (lfrac_out) then - ! frac_out (time,height_mlev,column,profile) - call addfld ('SCOPS_OUT',(/'cosp_scol','lev '/),'I','0=nocld,1=strcld,2=cnvcld','SCOPS Subcolumn output', & - flag_xyfill=.true., fill_value=R_UNDEF) - !! add scops ouptut to history file specified by the CAM namelist variable cosp_histfile_num - call add_default ('SCOPS_OUT',cosp_histfile_num,' ') - ! save sub-column outputs from ISCCP if ISCCP is run + call addfld('SCOPS_OUT', (/'cosp_scol','lev '/), 'I', '0=nocld,1=strcld,2=cnvcld', & + 'SCOPS Subcolumn output', flag_xyfill=.true., fill_value=R_UNDEF) + + call add_default('SCOPS_OUT',cosp_histfile_num,' ') + if (lisccp_sim) then - call add_default ('TAU_ISCCP',cosp_histfile_num,' ') - call add_default ('CLDPTOP_ISCCP',cosp_histfile_num,' ') + call add_default('TAU_ISCCP',cosp_histfile_num,' ') + call add_default('CLDPTOP_ISCCP',cosp_histfile_num,' ') end if - ! save sub-column outputs from calipso if calipso is run + if (llidar_sim) then - call add_default ('ATB532_CAL',cosp_histfile_num,' ') + call add_default('ATB532_CAL',cosp_histfile_num,' ') end if - ! save sub-column outputs from radar if radar is run + if (lradar_sim) then - call add_default ('DBZE_CS',cosp_histfile_num,' ') + call add_default('DBZE_CS',cosp_histfile_num,' ') end if end if !! ADDFLD, ADD_DEFAULT, OUTFLD CALLS FOR COSP OUTPUTS IF RUNNING COSP OFF-LINE - !! Note: A suggestion was to add all of the CAM variables needed to add to make it possible to run COSP off-line - !! These fields are available and can be called from the namelist though. Here, when the cosp_runall mode is invoked - !! all of the inputs are saved on the cam history file. This is good de-bugging functionality we should maintain. if (cosp_histfile_aux) then - call addfld ('PS_COSP', horiz_only, 'I','Pa', 'PS_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('TS_COSP', horiz_only, 'I','K', 'TS_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('P_COSP', (/ 'lev'/), 'I','Pa', 'P_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('PH_COSP', (/ 'lev'/), 'I','Pa', 'PH_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('ZLEV_COSP', (/ 'lev'/), 'I','m', 'ZLEV_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('ZLEV_HALF_COSP', (/ 'lev'/), 'I','m', 'ZLEV_HALF_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('T_COSP', (/ 'lev'/), 'I','K', 'T_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('RH_COSP', (/ 'lev'/), 'I','percent','RH_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('Q_COSP', (/ 'lev'/), 'I','kg/kg', 'Q_COSP', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('TAU_067', (/'cosp_scol','lev '/), 'I','1', 'Subcolumn 0.67micron optical depth', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('EMISS_11', (/'cosp_scol','lev '/), 'I','1', 'Subcolumn 11micron emissivity', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_fracliq', (/'cosp_scol','lev '/), 'I','1', 'Fraction of tau from liquid water', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_asym', (/'cosp_scol','lev '/), 'I','1', 'Asymmetry parameter (MODIS)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_ssa', (/'cosp_scol','lev '/), 'I','1', 'Single-scattering albedo (MODIS)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot', (/'cosp_scol','lev '/), 'I','1', 'Backscatter coefficient (CALIPSO)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot_ice', (/'cosp_scol','lev '/), 'I','1', 'Backscatter coefficient (CALIPSO)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot_liq', (/'cosp_scol','lev '/), 'I','1', 'Backscatter coefficient (CALIPSO)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot', (/'cosp_scol','lev '/), 'I','1', 'Vertically integrated ptical-depth (CALIPSO)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot_ice', (/'cosp_scol','lev '/), 'I','1', 'Vertically integrated ptical-depth (CALIPSO)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot_liq', (/'cosp_scol','lev '/), 'I','1', 'Vertically integrated ptical-depth (CALIPSO)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CS_z_vol', (/'cosp_scol','lev '/), 'I','1', 'Effective reflectivity factor (CLOUDSAT)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CS_kr_vol', (/'cosp_scol','lev '/), 'I','1', 'Attenuation coefficient (hydro) (CLOUDSAT)', & - flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CS_g_vol', (/'cosp_scol','lev '/), 'I','1', 'Attenuation coefficient (gases) (CLOUDSAT)', & - flag_xyfill=.true., fill_value=R_UNDEF) - - call add_default ('PS_COSP', cosp_histfile_aux_num,' ') - call add_default ('TS_COSP', cosp_histfile_aux_num,' ') - call add_default ('P_COSP', cosp_histfile_aux_num,' ') - call add_default ('PH_COSP', cosp_histfile_aux_num,' ') - call add_default ('ZLEV_COSP', cosp_histfile_aux_num,' ') - call add_default ('ZLEV_HALF_COSP', cosp_histfile_aux_num,' ') - call add_default ('T_COSP', cosp_histfile_aux_num,' ') - call add_default ('RH_COSP', cosp_histfile_aux_num,' ') - call add_default ('TAU_067', cosp_histfile_aux_num,' ') - call add_default ('EMISS_11', cosp_histfile_aux_num,' ') - call add_default ('MODIS_fracliq', cosp_histfile_aux_num,' ') - call add_default ('MODIS_asym', cosp_histfile_aux_num,' ') - call add_default ('MODIS_ssa', cosp_histfile_aux_num,' ') - call add_default ('CAL_betatot', cosp_histfile_aux_num,' ') - call add_default ('CAL_betatot_ice', cosp_histfile_aux_num,' ') - call add_default ('CAL_betatot_liq', cosp_histfile_aux_num,' ') - call add_default ('CAL_tautot', cosp_histfile_aux_num,' ') - call add_default ('CAL_tautot_ice', cosp_histfile_aux_num,' ') - call add_default ('CAL_tautot_liq', cosp_histfile_aux_num,' ') - call add_default ('CS_z_vol', cosp_histfile_aux_num,' ') - call add_default ('CS_kr_vol', cosp_histfile_aux_num,' ') - call add_default ('CS_g_vol', cosp_histfile_aux_num,' ') + call addfld ('PS_COSP', horiz_only, 'I','Pa', & + 'PS_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('TS_COSP', horiz_only, 'I','K', & + 'TS_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('P_COSP', (/ 'lev'/), 'I','Pa', & + 'P_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('PH_COSP', (/ 'lev'/), 'I','Pa', & + 'PH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('ZLEV_COSP', (/ 'lev'/), 'I','m', & + 'ZLEV_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('ZLEV_HALF_COSP', (/ 'lev'/), 'I','m', & + 'ZLEV_HALF_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('T_COSP', (/ 'lev'/), 'I','K', & + 'T_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('RH_COSP', (/ 'lev'/), 'I','percent', & + 'RH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('TAU_067', (/'cosp_scol','lev '/), 'I','1', & + 'Subcolumn 0.67micron optical depth', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('EMISS_11', (/'cosp_scol','lev '/), 'I','1', & + 'Subcolumn 11micron emissivity', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('MODIS_fracliq', (/'cosp_scol','lev '/), 'I','1', & + 'Fraction of tau from liquid water', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('MODIS_asym', (/'cosp_scol','lev '/), 'I','1', & + 'Asymmetry parameter (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('MODIS_ssa', (/'cosp_scol','lev '/), 'I','1', & + 'Single-scattering albedo (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CAL_betatot', (/'cosp_scol','lev '/), 'I','1', & + 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CAL_betatot_ice', (/'cosp_scol','lev '/), 'I','1', & + 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CAL_betatot_liq', (/'cosp_scol','lev '/), 'I','1', & + 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CAL_tautot', (/'cosp_scol','lev '/), 'I','1', & + 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CAL_tautot_ice', (/'cosp_scol','lev '/), 'I','1', & + 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CAL_tautot_liq', (/'cosp_scol','lev '/), 'I','1', & + 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CS_z_vol', (/'cosp_scol','lev '/), 'I','1', & + 'Effective reflectivity factor (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CS_kr_vol', (/'cosp_scol','lev '/), 'I','1', & + 'Attenuation coefficient (hydro) (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('CS_g_vol', (/'cosp_scol','lev '/), 'I','1', & + 'Attenuation coefficient (gases) (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) + + call add_default('PS_COSP', cosp_histfile_aux_num,' ') + call add_default('TS_COSP', cosp_histfile_aux_num,' ') + call add_default('P_COSP', cosp_histfile_aux_num,' ') + call add_default('PH_COSP', cosp_histfile_aux_num,' ') + call add_default('ZLEV_COSP', cosp_histfile_aux_num,' ') + call add_default('ZLEV_HALF_COSP', cosp_histfile_aux_num,' ') + call add_default('T_COSP', cosp_histfile_aux_num,' ') + call add_default('RH_COSP', cosp_histfile_aux_num,' ') + call add_default('TAU_067', cosp_histfile_aux_num,' ') + call add_default('EMISS_11', cosp_histfile_aux_num,' ') + call add_default('MODIS_fracliq', cosp_histfile_aux_num,' ') + call add_default('MODIS_asym', cosp_histfile_aux_num,' ') + call add_default('MODIS_ssa', cosp_histfile_aux_num,' ') + call add_default('CAL_betatot', cosp_histfile_aux_num,' ') + call add_default('CAL_betatot_ice', cosp_histfile_aux_num,' ') + call add_default('CAL_betatot_liq', cosp_histfile_aux_num,' ') + call add_default('CAL_tautot', cosp_histfile_aux_num,' ') + call add_default('CAL_tautot_ice', cosp_histfile_aux_num,' ') + call add_default('CAL_tautot_liq', cosp_histfile_aux_num,' ') + call add_default('CS_z_vol', cosp_histfile_aux_num,' ') + call add_default('CS_kr_vol', cosp_histfile_aux_num,' ') + call add_default('CS_g_vol', cosp_histfile_aux_num,' ') end if rei_idx = pbuf_get_index('REI') @@ -1098,18 +1041,19 @@ end subroutine setcosp2values ! ###################################################################################### ! SUBROUTINE cospsimulator_intr_run ! ###################################################################################### - subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,snow_tau_in,snow_emis_in) + subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in, snow_tau_in, snow_emis_in) + use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use camsrfexch, only: cam_in_t use constituents, only: cnst_get_ind use rad_constituents, only: rad_cnst_get_gas - use wv_saturation, only: qsat_water use interpolate_data, only: lininterp_init,lininterp,lininterp_finish,interp_type use physconst, only: pi, gravit use cam_history, only: outfld,hist_fld_col_active use cam_history_support, only: max_fieldname_len - use cmparray_mod, only: CmpDayNite, ExpDayNite + #ifdef USE_COSP use mod_cosp_config, only: R_UNDEF,parasol_nrefl, Nlvgrid, vgrid_zl, vgrid_zu use mod_cosp, only: cosp_simulator @@ -1134,69 +1078,18 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! ###################################################################################### integer :: lchnk ! chunk identifier integer :: ncol ! number of active atmospheric columns - integer :: i,k,ip,it,ipt,ih,id,ihd,is,ihs,isc,ihsc,ihm,ihmt,ihml,itim_old,ifld - - ! Variables for day/nite and orbital subsetting - ! Gathered indicies of day and night columns - ! chunk_column_index = IdxDay(daylight_column_index) - integer :: Nday ! Number of daylight columns - integer :: Nno ! Number of columns not using for simulator - integer, dimension(pcols) :: IdxDay ! Indices of daylight columns - integer, dimension(pcols) :: IdxNo ! Indices of columns not using for simulator - real(r8) :: tmp(pcols) ! tempororary variable for array expansion - real(r8) :: tmp1(pcols,pver) ! tempororary variable for array expansion - real(r8) :: tmp2(pcols,pver) ! tempororary variable for array expansion - real(r8) :: lon_cosp_day(pcols) ! tempororary variable for sunlit lons - real(r8) :: lat_cosp_day(pcols) ! tempororary variable for sunlit lats - real(r8) :: ptop_day(pcols,pver) ! tempororary variable for sunlit ptop - real(r8) :: pmid_day(pcols,pver) ! tempororary variable for sunlit pmid - real(r8) :: ztop_day(pcols,pver) ! tempororary variable for sunlit ztop - real(r8) :: zmid_day(pcols,pver) ! tempororary variable for sunlit zmid - real(r8) :: t_day(pcols,pver) ! tempororary variable for sunlit t - real(r8) :: rh_day(pcols,pver) ! tempororary variable for sunlit rh - real(r8) :: q_day(pcols,pver) ! tempororary variable for sunlit q - real(r8) :: concld_day(pcols,pver) ! tempororary variable for sunlit concld - real(r8) :: cld_day(pcols,pver) ! tempororary variable for sunlit cld - real(r8) :: ps_day(pcols) ! tempororary variable for sunlit ps - real(r8) :: ts_day(pcols) ! tempororary variable for sunlit ts - real(r8) :: landmask_day(pcols) ! tempororary variable for sunlit landmask - real(r8) :: o3_day(pcols,pver) ! tempororary variable for sunlit o3 - real(r8) :: us_day(pcols) ! tempororary variable for sunlit us - real(r8) :: vs_day(pcols) ! tempororary variable for sunlit vs - real(r8) :: mr_lsliq_day(pcols,pver) ! tempororary variable for sunlit mr_lsliq - real(r8) :: mr_lsice_day(pcols,pver) ! tempororary variable for sunlit mr_lsice - real(r8) :: mr_ccliq_day(pcols,pver) ! tempororary variable for sunlit mr_ccliq - real(r8) :: mr_ccice_day(pcols,pver) ! tempororary variable for sunlit mr_ccice - real(r8) :: rain_ls_interp_day(pcols,pver) ! tempororary variable for sunlit rain_ls_interp - real(r8) :: snow_ls_interp_day(pcols,pver) ! tempororary variable for sunlit snow_ls_interp - real(r8) :: grpl_ls_interp_day(pcols,pver) ! tempororary variable for sunlit grpl_ls_interp - real(r8) :: rain_cv_interp_day(pcols,pver) ! tempororary variable for sunlit rain_cv_interp - real(r8) :: snow_cv_interp_day(pcols,pver) ! tempororary variable for sunlit snow_cv_interp - real(r8) :: reff_cosp_day(pcols,pver,nhydro) ! tempororary variable for sunlit reff_cosp(:,:,:) - real(r8) :: dtau_s_day(pcols,pver) ! tempororary variable for sunlit dtau_s - real(r8) :: dtau_c_day(pcols,pver) ! tempororary variable for sunlit dtau_c - real(r8) :: dtau_s_snow_day(pcols,pver) ! tempororary variable for sunlit dtau_s_snow - real(r8) :: dem_s_day(pcols,pver) ! tempororary variable for sunlit dem_s - real(r8) :: dem_c_day(pcols,pver) ! tempororary variable for sunlit dem_c - real(r8) :: dem_s_snow_day(pcols,pver) ! tempororary variable for sunlit dem_s_snow - - ! Constants for optical depth calculation (from radcswmx.F90) - real(r8), parameter :: abarl = 2.817e-02_r8 ! A coefficient for extinction optical depth - real(r8), parameter :: bbarl = 1.305_r8 ! b coefficient for extinction optical depth - real(r8), parameter :: abari = 3.448e-03_r8 ! A coefficient for extinction optical depth - real(r8), parameter :: bbari = 2.431_r8 ! b coefficient for extinction optical depth - real(r8), parameter :: cldmin = 1.0e-80_r8 ! note: cldmin much less than cldmin from cldnrh - real(r8), parameter :: cldeps = 0.0_r8 + integer :: i, k, kk + integer :: itim_old + integer :: ip, it + integer :: ipt + integer :: ih, ihd, ihs, ihsc, ihm, ihmt, ihml + integer :: isc + integer :: is + integer :: id ! Microphysics variables - integer, parameter :: ncnstmax=4 ! number of constituents - character(len=8), dimension(ncnstmax), parameter :: & ! constituent names - cnst_names = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE'/) - integer :: ncnst ! number of constituents (can vary) integer :: ixcldliq ! cloud liquid amount index for state%q integer :: ixcldice ! cloud ice amount index - integer :: ixnumliq ! cloud liquid number index - integer :: ixnumice ! cloud ice water index ! COSP-related local vars type(cosp_outputs) :: cospOUT ! COSP simulator outputs @@ -1204,51 +1097,39 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn type(cosp_column_inputs) :: cospstateIN ! COSP model fields needed by simulators ! COSP input variables that depend on CAM - ! 1) Npoints = number of gridpoints COSP will process (without subsetting, Npoints=ncol) - - real(r8), parameter :: time = 1.0_r8 ! time ! Time since start of run [days], set to 1 bc running over single CAM timestep - real(r8), parameter :: time_bnds(2)=(/0.5_r8,1.5_r8/) ! time_bnds ! Time boundaries - new in cosp v1.3, set following cosp_test.f90 line 121 integer :: Npoints ! Number of gridpoints COSP will process logical :: use_reff ! True if effective radius to be used by radar simulator ! (always used by lidar) logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm real(r8), parameter :: emsfc_lw = 0.99_r8 ! longwave emissivity of surface at 10.5 microns - ! set value same as in cloudsimulator.F90 ! Local vars related to calculations to go from CAM input to COSP input ! cosp convective value includes both deep and shallow convection - real(r8) :: ptop(pcols,pver) ! top interface pressure (Pa) - real(r8) :: ztop(pcols,pver) ! top interface height asl (m) - real(r8) :: pbot(pcols,pver) ! bottom interface pressure (Pa) - real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) - real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) - real(r8) :: lat_cosp(pcols) ! lat for cosp (degrees_north) - real(r8) :: lon_cosp(pcols) ! lon for cosp (degrees_east) - real(r8) :: landmask(pcols) ! landmask (0 or 1) - real(r8) :: mr_lsliq(pcols,pver) ! mixing_ratio_large_scale_cloud_liquid (kg/kg) - real(r8) :: mr_lsice(pcols,pver) ! mixing_ratio_large_scale_cloud_ice (kg/kg) - real(r8) :: mr_ccliq(pcols,pver) ! mixing_ratio_convective_cloud_liquid (kg/kg) - real(r8) :: mr_ccice(pcols,pver) ! mixing_ratio_convective_cloud_ice (kg/kg) - real(r8) :: rain_cv(pcols,pverp) ! interface flux_convective_cloud_rain (kg m^-2 s^-1) - real(r8) :: snow_cv(pcols,pverp) ! interface flux_convective_cloud_snow (kg m^-2 s^-1) - real(r8) :: rain_cv_interp(pcols,pver) ! midpoint flux_convective_cloud_rain (kg m^-2 s^-1) - real(r8) :: snow_cv_interp(pcols,pver) ! midpoint flux_convective_cloud_snow (kg m^-2 s^-1) - real(r8) :: grpl_ls_interp(pcols,pver) ! midpoint ls grp flux, should be 0 - real(r8) :: rain_ls_interp(pcols,pver) ! midpoint ls rain flux (kg m^-2 s^-1) - real(r8) :: snow_ls_interp(pcols,pver) ! midpoint ls snow flux - real(r8) :: reff_cosp(pcols,pver,nhydro) ! effective radius for cosp input - real(r8) :: rh(pcols,pver) ! relative_humidity_liquid_water (%) - real(r8) :: es(pcols,pver) ! saturation vapor pressure - real(r8) :: qs(pcols,pver) ! saturation mixing ratio (kg/kg), saturation specific humidity - real(r8) :: cld_swtau(pcols,pver) ! incloud sw tau for input to COSP - real(r8) :: dtau_s(pcols,pver) ! dtau_s - Optical depth of stratiform cloud at 0.67 um - real(r8) :: dtau_c(pcols,pver) ! dtau_c - Optical depth of convective cloud at 0.67 um - real(r8) :: dtau_s_snow(pcols,pver) ! dtau_s_snow - Grid-box mean Optical depth of stratiform snow at 0.67 um - real(r8) :: dem_s(pcols,pver) ! dem_s - Longwave emis of stratiform cloud at 10.5 um - real(r8) :: dem_c(pcols,pver) ! dem_c - Longwave emis of convective cloud at 10.5 um - real(r8) :: dem_s_snow(pcols,pver) ! dem_s_snow - Grid-box mean Optical depth of stratiform snow at 10.5 um - integer :: cam_sunlit(pcols) ! cam_sunlit - Sunlit flag(1-sunlit/0-dark). - integer :: nSunLit,nNoSunLit ! Number of sunlit (not sunlit) scenes. + real(r8), allocatable :: & + zmid(:,:), & ! layer midpoint height asl (m) + zbot(:,:), & ! bottom interface height asl (m) + landmask(:), & ! landmask (0 or 1) + mr_ccliq(:,:), & ! mixing_ratio_convective_cloud_liquid (kg/kg) + mr_ccice(:,:), & ! mixing_ratio_convective_cloud_ice (kg/kg) + mr_lsliq(:,:), & ! mixing_ratio_large_scale_cloud_liquid (kg/kg) + mr_lsice(:,:), & ! mixing_ratio_large_scale_cloud_ice (kg/kg) + rain_cv(:,:), & ! interface flux_convective_cloud_rain (kg m^-2 s^-1) + snow_cv(:,:), & ! interface flux_convective_cloud_snow (kg m^-2 s^-1) + rain_cv_interp(:,:), & ! midpoint flux_convective_cloud_rain (kg m^-2 s^-1) + snow_cv_interp(:,:), & ! midpoint flux_convective_cloud_snow (kg m^-2 s^-1) + rain_ls_interp(:,:), & ! midpoint ls rain flux (kg m^-2 s^-1) + snow_ls_interp(:,:), & ! midpoint ls snow flux + grpl_ls_interp(:,:), & ! midpoint ls grp flux, set to 0 + reff_cosp(:,:,:), & ! effective radius for cosp input + dtau_s(:,:), & ! Optical depth of stratiform cloud at 0.67 um + dtau_c(:,:), & ! Optical depth of convective cloud at 0.67 um + dtau_s_snow(:,:), & ! Grid-box mean Optical depth of stratiform snow at 0.67 um + dem_s(:,:), & ! Longwave emis of stratiform cloud at 10.5 um + dem_c(:,:), & ! Longwave emis of convective cloud at 10.5 um + dem_s_snow(:,:) ! Grid-box mean Optical depth of stratiform snow at 10.5 um + + integer :: cam_sunlit(pcols) ! cam_sunlit - Sunlit flag(1-sunlit/0-dark). + integer :: nSunLit ! Number of sunlit (not sunlit) scenes. ! ###################################################################################### ! Simulator output info @@ -1266,9 +1147,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn 'CS_NOPRECIP ', 'CS_RAINPOSS ', 'CS_RAINPROB ', & 'CS_RAINCERT ', 'CS_SNOWPOSS ', 'CS_SNOWCERT ', & 'CS_MIXPOSS ', 'CS_MIXCERT ', 'CS_RAINHARD ', & - 'CS_UN ', 'CS_PIA '/)!, 'CAM_MP_CVRAIN ', & - !'CAM_MP_CVSNOW ', 'CAM_MP_LSRAIN ', 'CAM_MP_LSSNOW ', & - !'CAM_MP_LSGRPL '/) + 'CS_UN ', 'CS_PIA '/) ! CALIPSO outputs character(len=max_fieldname_len),dimension(nf_calipso),parameter :: & @@ -1277,11 +1156,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn 'CLD_CAL_ICE ','CLD_CAL_UN ','CLD_CAL_TMP ','CLD_CAL_TMPLIQ ','CLD_CAL_TMPICE ',& 'CLD_CAL_TMPUN ','CLDTOT_CAL_ICE ','CLDTOT_CAL_LIQ ','CLDTOT_CAL_UN ','CLDHGH_CAL_ICE ',& 'CLDHGH_CAL_LIQ ','CLDHGH_CAL_UN ','CLDMED_CAL_ICE ','CLDMED_CAL_LIQ ','CLDMED_CAL_UN ',& - 'CLDLOW_CAL_ICE ','CLDLOW_CAL_LIQ ','CLDLOW_CAL_UN '/)!, & -! 'CLDOPQ_CAL ','CLDTHN_CAL ','CLDZOPQ_CAL ','CLDOPQ_CAL_2D ','CLDTHN_CAL_2D ',& -! 'CLDZOPQ_CAL_2D ','OPACITY_CAL_2D ','CLDOPQ_CAL_TMP ','CLDTHN_CAL_TMP ','CLDZOPQ_CAL_TMP',& -! 'CLDOPQ_CAL_Z ','CLDTHN_CAL_Z ','CLDTHN_CAL_EMIS','CLDOPQ_CAL_SE ','CLDTHN_CAL_SE ',& -! 'CLDZOPQ_CAL_SE' /) + 'CLDLOW_CAL_ICE ','CLDLOW_CAL_LIQ ','CLDLOW_CAL_UN '/) ! ISCCP outputs character(len=max_fieldname_len),dimension(nf_isccp),parameter :: & fname_isccp=(/'FISCCP1_COSP ','CLDTOT_ISCCP ','MEANCLDALB_ISCCP',& @@ -1299,7 +1174,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn 'CLRLMODIS '/) logical :: run_radar(nf_radar,pcols) ! logical telling you if you should run radar simulator - logical :: run_calipso(nf_calipso,pcols) ! logical telling you if you should run calipso simulator + logical :: run_calipso(nf_calipso,pcols) ! logical telling you if you should run calipso simulator logical :: run_isccp(nf_isccp,pcols) ! logical telling you if you should run isccp simulator logical :: run_misr(nf_misr,pcols) ! logical telling you if you should run misr simulator logical :: run_modis(nf_modis,pcols) ! logical telling you if you should run modis simulator @@ -1321,87 +1196,71 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8), pointer, dimension(:,:) :: cv_reffliq ! convective cld liq effective drop radius (microns) real(r8), pointer, dimension(:,:) :: cv_reffice ! convective cld ice effective drop size (microns) - !! precip flux pointers (use for cam4 or cam5) + !! precip flux pointers real(r8), target, dimension(pcols,pverp) :: zero_ifc ! zero array for interface fields not in the pbuf - ! Added pointers; pbuff in zm_conv_intr.F90, calc in zm_conv.F90 real(r8), pointer, dimension(:,:) :: dp_flxprc ! deep interface gbm flux_convective_cloud_rain+snow (kg m^-2 s^-1) real(r8), pointer, dimension(:,:) :: dp_flxsnw ! deep interface gbm flux_convective_cloud_snow (kg m^-2 s^-1) - ! More pointers; pbuf in convect_shallow.F90, calc in hk_conv.F90/convect_shallow.F90 (CAM4), uwshcu.F90 (CAM5) real(r8), pointer, dimension(:,:) :: sh_flxprc ! shallow interface gbm flux_convective_cloud_rain+snow (kg m^-2 s^-1) real(r8), pointer, dimension(:,:) :: sh_flxsnw ! shallow interface gbm flux_convective_cloud_snow (kg m^-2 s^-1) - ! More pointers; pbuf in stratiform.F90, getting from pbuf here - ! a) added as output to pcond subroutine in cldwat.F90 and to nmicro_pcond subroutine in cldwat2m_micro.F90 real(r8), pointer, dimension(:,:) :: ls_flxprc ! stratiform interface gbm flux_cloud_rain+snow (kg m^-2 s^-1) real(r8), pointer, dimension(:,:) :: ls_flxsnw ! stratiform interface gbm flux_cloud_snow (kg m^-2 s^-1) !! cloud mixing ratio pointers (note: large-scale in state) - ! More pointers; pbuf in convect_shallow.F90 (cam4) or stratiform.F90 (cam5) - ! calc in hk_conv.F90 (CAM4 should be 0!), uwshcu.F90 but then affected by micro so values from stratiform.F90 (CAM5) real(r8), pointer, dimension(:,:) :: sh_cldliq ! shallow gbm cloud liquid water (kg/kg) real(r8), pointer, dimension(:,:) :: sh_cldice ! shallow gbm cloud ice water (kg/kg) - ! More pointers; pbuf in zm_conv_intr.F90, calc in zm_conv.F90, 0 for CAM4 and CAM5 (same convection scheme) real(r8), pointer, dimension(:,:) :: dp_cldliq ! deep gbm cloud liquid water (kg/kg) real(r8), pointer, dimension(:,:) :: dp_cldice ! deep gmb cloud ice water (kg/kg) ! Output CAM variables - ! Notes: - ! 1) use pcols (maximum number of columns that code could use, maybe 16) - ! pcols vs. ncol. ncol is the number of columns a chunk is actually using, pcols is maximum number - ! 2) Mixed variables rules/notes, need to collapse because CAM history does not support increased dimensionality - ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nlay, ntau_cosp*nhtmisr_cosp - ! a) always making mixed variables VERTICAL*OTHER, e.g., pressure*tau or ht*dbze - ! b) always collapsing output as V1_1/V2_1...V1_1/V2_N ; V1_2/V2_1 ...V1_2/V2_N etc. to V1_N/V2_1 ... V1_N/V2_N - ! c) here, need vars for both multi-dimensional output from COSP, and two-dimensional output from CAM - ! 3) ntime=1, nprofile=ncol - ! 4) dimensions listed in COSP units are from netcdf output from cosp test case, and are not necessarily in the - ! correct order. In fact, most of them are not as I discovered after trying to run COSP in-line. - ! BE says this could be because FORTRAN and C (netcdf defaults to C) have different conventions. - ! 5) !! Note: after running COSP, it looks like height_mlev is actually the model levels after all!! - real(r8) :: clisccp2(pcols,ntau_cosp,nprs_cosp) ! clisccp2 (time,tau,plev,profile) - real(r8) :: cfad_dbze94(pcols,CLOUDSAT_DBZE_BINS,nht_cosp) ! cfad_dbze94 (time,height,dbze,profile) - real(r8) :: cfad_lidarsr532(pcols,nsr_cosp,nht_cosp) ! cfad_lidarsr532 (time,height,scat_ratio,profile) - real(r8) :: dbze94(pcols,nscol_cosp,nlay) ! dbze94 (time,height_mlev,column,profile) - real(r8) :: atb532(pcols,nscol_cosp,nlay) ! atb532 (time,height_mlev,column,profile) - real(r8) :: clMISR(pcols,ntau_cosp,nhtmisr_cosp) ! clMISR (time,tau,CTH_height_bin,profile) - real(r8) :: frac_out(pcols,nscol_cosp,nlay) ! frac_out (time,height_mlev,column,profile) - real(r8) :: cldtot_isccp(pcols) ! CAM tclisccp (time,profile) - real(r8) :: meancldalb_isccp(pcols) ! CAM albisccp (time,profile) - real(r8) :: meanptop_isccp(pcols) ! CAM ctpisccp (time,profile) - real(r8) :: cldlow_cal(pcols) ! CAM cllcalipso (time,profile) - real(r8) :: cldmed_cal(pcols) ! CAM clmcalipso (time,profile) - real(r8) :: cldhgh_cal(pcols) ! CAM clhcalipso (time,profile) - real(r8) :: cldtot_cal(pcols) ! CAM cltcalipso (time,profile) - real(r8) :: cldtot_cal_ice(pcols) ! CAM (time,profile) !!+cosp1.4 - real(r8) :: cldtot_cal_liq(pcols) ! CAM (time,profile) - real(r8) :: cldtot_cal_un(pcols) ! CAM (time,profile) - real(r8) :: cldhgh_cal_ice(pcols) ! CAM (time,profile) - real(r8) :: cldhgh_cal_liq(pcols) ! CAM (time,profile) - real(r8) :: cldhgh_cal_un(pcols) ! CAM (time,profile) - real(r8) :: cldmed_cal_ice(pcols) ! CAM (time,profile) - real(r8) :: cldmed_cal_liq(pcols) ! CAM (time,profile) - real(r8) :: cldmed_cal_un(pcols) ! CAM (time,profile) - real(r8) :: cldlow_cal_ice(pcols) ! CAM (time,profile) - real(r8) :: cldlow_cal_liq(pcols) ! CAM (time,profile) - real(r8) :: cldlow_cal_un(pcols) ! CAM (time,profile) !+cosp1.4 - real(r8) :: cld_cal(pcols,nht_cosp) ! CAM clcalipso (time,height,profile) - real(r8) :: cld_cal_liq(pcols,nht_cosp) ! CAM (time,height,profile) !+cosp1.4 - real(r8) :: cld_cal_ice(pcols,nht_cosp) ! CAM (time,height,profile) - real(r8) :: cld_cal_un(pcols,nht_cosp) ! CAM (time,height,profile) - real(r8) :: cld_cal_tmp(pcols,nht_cosp) ! CAM (time,height,profile) - real(r8) :: cld_cal_tmpliq(pcols,nht_cosp) ! CAM (time,height,profile) - real(r8) :: cld_cal_tmpice(pcols,nht_cosp) ! CAM (time,height,profile) - real(r8) :: cld_cal_tmpun(pcols,nht_cosp) ! CAM (time,height,profile) !+cosp1.4 - real(r8) :: cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS)! CAM cfad_dbze94 (time,height,dbze,profile) - real(r8) :: cfad_sr532_cal(pcols,nht_cosp*nsr_cosp) ! CAM cfad_lidarsr532 (time,height,scat_ratio,profile) - real(r8) :: tau_isccp(pcols,nscol_cosp) ! CAM boxtauisccp (time,column,profile) - real(r8) :: cldptop_isccp(pcols,nscol_cosp) ! CAM boxptopisccp (time,column,profile) - real(r8) :: meantau_isccp(pcols) ! CAM tauisccp (time,profile) - real(r8) :: meantb_isccp(pcols) ! CAM meantbisccp (time,profile) - real(r8) :: meantbclr_isccp(pcols) ! CAM meantbclrisccp (time,profile) - real(r8) :: dbze_cs(pcols,nlay*nscol_cosp) ! CAM dbze94 (time,height_mlev,column,profile) - real(r8) :: cldtot_calcs(pcols) ! CAM cltlidarradar (time,profile) - real(r8) :: cldtot_cs(pcols) ! CAM cltradar (time,profile) - real(r8) :: cldtot_cs2(pcols) ! CAM cltradar2 (time,profile) + ! Multiple "mdims" are collapsed because CAM history buffers only support one mdim. + ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nlay, + ! ntau_cosp*nhtmisr_cosp + ! Always making mixed variables VERTICAL*OTHER, e.g., pressure*tau or ht*dbze + real(r8) :: clisccp2(pcols,ntau_cosp,nprs_cosp) + real(r8) :: cfad_dbze94(pcols,CLOUDSAT_DBZE_BINS,nht_cosp) + real(r8) :: cfad_lidarsr532(pcols,nsr_cosp,nht_cosp) + real(r8) :: dbze94(pcols,nscol_cosp,nlay) + real(r8) :: atb532(pcols,nscol_cosp,nlay) + real(r8) :: clMISR(pcols,ntau_cosp,nhtmisr_cosp) + real(r8) :: frac_out(pcols,nscol_cosp,nlay) + real(r8) :: cldtot_isccp(pcols) + real(r8) :: meancldalb_isccp(pcols) + real(r8) :: meanptop_isccp(pcols) + real(r8) :: cldlow_cal(pcols) + real(r8) :: cldmed_cal(pcols) + real(r8) :: cldhgh_cal(pcols) + real(r8) :: cldtot_cal(pcols) + real(r8) :: cldtot_cal_ice(pcols) + real(r8) :: cldtot_cal_liq(pcols) + real(r8) :: cldtot_cal_un(pcols) + real(r8) :: cldhgh_cal_ice(pcols) + real(r8) :: cldhgh_cal_liq(pcols) + real(r8) :: cldhgh_cal_un(pcols) + real(r8) :: cldmed_cal_ice(pcols) + real(r8) :: cldmed_cal_liq(pcols) + real(r8) :: cldmed_cal_un(pcols) + real(r8) :: cldlow_cal_ice(pcols) + real(r8) :: cldlow_cal_liq(pcols) + real(r8) :: cldlow_cal_un(pcols) + real(r8) :: cld_cal(pcols,nht_cosp) + real(r8) :: cld_cal_liq(pcols,nht_cosp) + real(r8) :: cld_cal_ice(pcols,nht_cosp) + real(r8) :: cld_cal_un(pcols,nht_cosp) + real(r8) :: cld_cal_tmp(pcols,nht_cosp) + real(r8) :: cld_cal_tmpliq(pcols,nht_cosp) + real(r8) :: cld_cal_tmpice(pcols,nht_cosp) + real(r8) :: cld_cal_tmpun(pcols,nht_cosp) + real(r8) :: cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS) + real(r8) :: cfad_sr532_cal(pcols,nht_cosp*nsr_cosp) + real(r8) :: tau_isccp(pcols,nscol_cosp) + real(r8) :: cldptop_isccp(pcols,nscol_cosp) + real(r8) :: meantau_isccp(pcols) + real(r8) :: meantb_isccp(pcols) + real(r8) :: meantbclr_isccp(pcols) + real(r8) :: dbze_cs(pcols,nlay*nscol_cosp) + real(r8) :: cldtot_calcs(pcols) + real(r8) :: cldtot_cs(pcols) + real(r8) :: cldtot_cs2(pcols) real(r8) :: ptcloudsatflag0(pcols) real(r8) :: ptcloudsatflag1(pcols) real(r8) :: ptcloudsatflag2(pcols) @@ -1413,12 +1272,12 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn real(r8) :: ptcloudsatflag8(pcols) real(r8) :: ptcloudsatflag9(pcols) real(r8) :: cloudsatpia(pcols) - real(r8) :: cld_cal_notcs(pcols,nht_cosp) ! CAM clcalipso2 (time,height,profile) - real(r8) :: atb532_cal(pcols,nlay*nscol_cosp) ! CAM atb532 (time,height_mlev,column,profile) - real(r8) :: mol532_cal(pcols,nlay) ! CAM beta_mol532 (time,height_mlev,profile) - real(r8) :: cld_misr(pcols,nhtmisr_cosp*ntau_cosp) ! CAM clMISR (time,tau,CTH_height_bin,profile) - real(r8) :: refl_parasol(pcols,nsza_cosp) ! CAM parasol_refl (time,sza,profile) - real(r8) :: scops_out(pcols,nlay*nscol_cosp) ! CAM frac_out (time,height_mlev,column,profile) + real(r8) :: cld_cal_notcs(pcols,nht_cosp) + real(r8) :: atb532_cal(pcols,nlay*nscol_cosp) + real(r8) :: mol532_cal(pcols,nlay) + real(r8) :: cld_misr(pcols,nhtmisr_cosp*ntau_cosp) + real(r8) :: refl_parasol(pcols,nsza_cosp) + real(r8) :: scops_out(pcols,nlay*nscol_cosp) real(r8) :: cltmodis(pcols) real(r8) :: clwmodis(pcols) real(r8) :: climodis(pcols) @@ -1448,7 +1307,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn asym34_out,ssa34_out type(interp_type) :: interp_wgts - integer, parameter :: extrap_method = 1 ! sets extrapolation method to boundary value (1) + integer, parameter :: extrap_method = 1 ! sets extrapolation method to boundary value (1) ! COSPv2 stuff character(len=256),dimension(100) :: cosp_status @@ -1458,20 +1317,14 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! ###################################################################################### ! Initialization ! ###################################################################################### - ! Find the chunk and ncol from the state vector - lchnk = state%lchnk ! state variable contains a number of columns, one chunk + + lchnk = state%lchnk ! chunk ID ncol = state%ncol ! number of columns in the chunk + Npoints = ncol ! number of COSP gridpoints zero_ifc = 0._r8 - ! Initialize temporary variables as R_UNDEF - need to do this otherwise array expansion puts garbage in history - ! file for columns over which COSP did make calculations. - tmp(1:pcols) = R_UNDEF - tmp1(1:pcols,1:pver) = R_UNDEF - tmp2(1:pcols,1:pver) = R_UNDEF - ! Initialize CAM variables as R_UNDEF, important for history files because it will exclude these from averages - ! (multi-dimensional output that will be collapsed) ! initialize over all pcols, not just ncol. missing values needed in chunks where ncol 0) then @@ -1703,217 +1537,139 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! CALCULATE COSP INPUT VARIABLES FROM CAM VARIABLES, done for all columns within chunk !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - ! 0) Create ptop/ztop for gbx%pf and gbx%zlev are for the the interface, - ! also reverse CAM height/pressure values for input into CSOP - ! CAM state%pint from top to surface, COSP wants surface to top. - - ! Initalize - ptop(1:ncol,1:pver)=0._r8 - pbot(1:ncol,1:pver)=0._r8 - ztop(1:ncol,1:pver)=0._r8 - zbot(1:ncol,1:pver)=0._r8 - zmid(1:ncol,1:pver)=0._r8 - - ! assign values from top - do k=1,pverp-1 - ! assign values from top - ptop(1:ncol,k)=state%pint(1:ncol,pverp-k) - ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) - ! assign values from bottom - pbot(1:ncol,k)=state%pint(1:ncol,pverp-k+1) - zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) - end do - - ! add surface height (surface geopotential/gravity) to convert CAM heights based on geopotential above surface into height above sea level - do k=1,pver - do i=1,ncol - ztop(i,k)=ztop(i,k)+state%phis(i)/gravit - zbot(i,k)=zbot(i,k)+state%phis(i)/gravit - zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit - end do - end do - - ! 1) lat/lon - convert from radians to cosp input type - ! Initalize - lat_cosp(1:ncol)=0._r8 - lon_cosp(1:ncol)=0._r8 - ! convert from radians to degrees_north and degrees_east - lat_cosp=state%lat*180._r8/(pi) ! needs to go from -90 to +90 degrees north - lon_cosp=state%lon*180._r8/(pi) ! needs to go from 0 to 360 degrees east - - ! 2) rh - relative_humidity_liquid_water (%) - ! calculate from CAM q and t using CAM built-in functions - do k = 1, pver - call qsat_water(state%t(1:ncol,k), state%pmid(1:ncol,k), es(1:ncol,k), qs(1:ncol,k), ncol) - end do - ! initialize rh - rh(1:ncol,1:pver)=0._r8 - - ! calculate rh - do k=1,pver - do i=1,ncol - rh(i,k)=(q(i,k)/qs(i,k))*100 - end do + + allocate( & + zmid(ncol,nlay), & + zbot(ncol,nlay), & + landmask(ncol), & + mr_ccliq(ncol,nlay), & + mr_ccice(ncol,nlay), & + mr_lsliq(ncol,nlay), & + mr_lsice(ncol,nlay), & + rain_cv(ncol,nlayp), & + snow_cv(ncol,nlayp), & + rain_cv_interp(ncol,nlay), & + snow_cv_interp(ncol,nlay), & + rain_ls_interp(ncol,nlay), & + snow_ls_interp(ncol,nlay), & + grpl_ls_interp(ncol,nlay), & + reff_cosp(ncol,nlay,nhydro), & + dtau_s(ncol,nlay), & + dtau_c(ncol,nlay), & + dtau_s_snow(ncol,nlay), & + dem_s(ncol,nlay), & + dem_c(ncol,nlay), & + dem_s_snow(ncol,nlay) & + ) + + ! add surface height (surface geopotential/gravity) to convert CAM heights based on + ! geopotential above surface into height above sea level + do k = 1, nlay + zmid(:,k) = state%zm(:ncol,ktop+k-1) + state%phis(:ncol)/gravit + ! bottom interface of each layer + zbot(:,k) = state%zi(:ncol,ktop+k) + state%phis(:ncol)/gravit end do - ! 3) landmask - calculate from cam_in%landfrac - ! initalize landmask - landmask(1:ncol)=0._r8 - ! calculate landmask - do i=1,ncol - if (cam_in%landfrac(i).gt.0.01_r8) landmask(i)= 1 + landmask = 0._r8 + do i = 1, ncol + if (cam_in%landfrac(i) > 0.01_r8) landmask(i)= 1 end do - ! 4) calculate necessary input cloud/precip variables + ! calculate necessary input cloud/precip variables ! CAM4 note: don't take the cloud water from the hack shallow convection scheme or the deep convection. ! cloud water values for convection are the same as the stratiform value. (Sungsu) ! all precip fluxes are mid points, all values are grid-box mean ("gbm") (Yuying) - ! initialize local variables - mr_ccliq(1:ncol,1:pver) = 0._r8 - mr_ccice(1:ncol,1:pver) = 0._r8 - mr_lsliq(1:ncol,1:pver) = 0._r8 - mr_lsice(1:ncol,1:pver) = 0._r8 - grpl_ls_interp(1:ncol,1:pver) = 0._r8 - rain_ls_interp(1:ncol,1:pver) = 0._r8 - snow_ls_interp(1:ncol,1:pver) = 0._r8 - rain_cv(1:ncol,1:pverp) = 0._r8 - snow_cv(1:ncol,1:pverp) = 0._r8 - rain_cv_interp(1:ncol,1:pver) = 0._r8 - snow_cv_interp(1:ncol,1:pver) = 0._r8 - reff_cosp(1:ncol,1:pver,1:nhydro) = 0._r8 ! reff_cosp dimensions should be same as cosp - ! (reff_cosp has 9 hydrometeor dimension) - use_precipitation_fluxes = .true. !!! consistent with cam4 implementation. - ! add together deep and shallow convection precipitation fluxes, recall *_flxprc variables are rain+snow - rain_cv(1:ncol,1:pverp) = (sh_flxprc(1:ncol,1:pverp)-sh_flxsnw(1:ncol,1:pverp)) + & - (dp_flxprc(1:ncol,1:pverp)-dp_flxsnw(1:ncol,1:pverp)) - snow_cv(1:ncol,1:pverp) = sh_flxsnw(1:ncol,1:pverp) + dp_flxsnw(1:ncol,1:pverp) + ! Add together deep and shallow convection precipitation fluxes. + ! Note: sh_flxprc and dp_flxprc variables are rain+snow + rain_cv = (sh_flxprc(:ncol,ktop:pverp) - sh_flxsnw(:ncol,ktop:pverp)) + & + (dp_flxprc(:ncol,ktop:pverp) - dp_flxsnw(:ncol,ktop:pverp)) + snow_cv = sh_flxsnw(:ncol,ktop:pverp) + dp_flxsnw(:ncol,ktop:pverp) ! interpolate interface precip fluxes to mid points - do i=1,ncol - ! find weights (pressure weighting?) - call lininterp_init(state%zi(i,1:pverp),pverp,state%zm(i,1:pver),pver,extrap_method,interp_wgts) - ! interpolate lininterp1d(arrin, nin, arrout, nout, interp_wgts) - ! note: lininterp is an interface, contains lininterp1d -- code figures out to use lininterp1d. - call lininterp(rain_cv(i,1:pverp),pverp,rain_cv_interp(i,1:pver),pver,interp_wgts) - call lininterp(snow_cv(i,1:pverp),pverp,snow_cv_interp(i,1:pver),pver,interp_wgts) - call lininterp(ls_flxprc(i,1:pverp),pverp,rain_ls_interp(i,1:pver),pver,interp_wgts) - call lininterp(ls_flxsnw(i,1:pverp),pverp,snow_ls_interp(i,1:pver),pver,interp_wgts) + do i = 1, ncol + ! find weights + call lininterp_init(state%zi(i,ktop:pverp), nlayp, state%zm(i,ktop:pver), nlay, & + extrap_method, interp_wgts) + ! interpolate lininterp(arrin, nin, arrout, nout, interp_wgts) + call lininterp(rain_cv(i,:), nlayp, rain_cv_interp(i,:), nlay, interp_wgts) + call lininterp(snow_cv(i,:), nlayp, snow_cv_interp(i,:), nlay, interp_wgts) + call lininterp(ls_flxprc(i,ktop:pverp), nlayp, rain_ls_interp(i,:), nlay, interp_wgts) + call lininterp(ls_flxsnw(i,ktop:pverp), nlayp, snow_ls_interp(i,:), nlay, interp_wgts) call lininterp_finish(interp_wgts) !! ls_flxprc is for rain+snow, find rain_ls_interp by subtracting off snow_ls_interp - rain_ls_interp(i,1:pver)=rain_ls_interp(i,1:pver)-snow_ls_interp(i,1:pver) + rain_ls_interp(i,:) = rain_ls_interp(i,:) - snow_ls_interp(i,:) end do + + grpl_ls_interp = 0._r8 !! CAM5 cloud mixing ratio calculations !! Note: Although CAM5 has non-zero convective cloud mixing ratios that affect the model state, !! Convective cloud water is NOT part of radiation calculations. - do k=1,pver - do i=1,ncol - if (cld(i,k) .gt. 0._r8) then + mr_ccliq = 0._r8 + mr_ccice = 0._r8 + mr_lsliq = 0._r8 + mr_lsice = 0._r8 + do k = 1, nlay + kk = ktop + k -1 + do i = 1, ncol + if (cld(i,k) > 0._r8) then !! note: convective mixing ratio is the sum of shallow and deep convective clouds in CAM5 - mr_ccliq(i,k) = sh_cldliq(i,k) + dp_cldliq(i,k) - mr_ccice(i,k) = sh_cldice(i,k) + dp_cldice(i,k) - mr_lsliq(i,k)=state%q(i,k,ixcldliq) ! mr_lsliq, mixing_ratio_large_scale_cloud_liquid, state only includes stratiform (kg/kg) - mr_lsice(i,k)=state%q(i,k,ixcldice) ! mr_lsice - mixing_ratio_large_scale_cloud_ice, state only includes stratiform (kg/kg) - else - mr_ccliq(i,k) = 0._r8 - mr_ccice(i,k) = 0._r8 - mr_lsliq(i,k) = 0._r8 - mr_lsice(i,k) = 0._r8 + mr_ccliq(i,k) = sh_cldliq(i,kk) + dp_cldliq(i,kk) + mr_ccice(i,k) = sh_cldice(i,kk) + dp_cldice(i,kk) + mr_lsliq(i,k) = state%q(i,kk,ixcldliq) ! state only includes stratiform (kg/kg) + mr_lsice(i,k) = state%q(i,kk,ixcldice) ! state only includes stratiform (kg/kg) end if end do end do - !! Previously, I had set use_reff=.false. - !! use_reff = .false. !! if you use this,all sizes use DEFAULT_LIDAR_REFF = 30.0e-6 meters - - !! The specification of reff_cosp now follows e-mail discussion with Yuying in January 2011. (see above) - !! All of the values that I have assembled in the code are in microns... convert to meters here since that is what COSP wants. + !! if use_reff=.false. then all sizes use DEFAULT_LIDAR_REFF = 30.0e-6 meters use_reff = .true. - reff_cosp(1:ncol,1:pver,1) = rel(1:ncol,1:pver)*1.e-6_r8 !! LSCLIQ (same as effc and effliq in stratiform.F90) - reff_cosp(1:ncol,1:pver,2) = rei(1:ncol,1:pver)*1.e-6_r8 !! LSCICE (same as effi and effice in stratiform.F90) - reff_cosp(1:ncol,1:pver,3) = ls_reffrain(1:ncol,1:pver)*1.e-6_r8 !! LSRAIN (calculated in cldwat2m_micro.F90, passed to stratiform.F90) - reff_cosp(1:ncol,1:pver,4) = ls_reffsnow(1:ncol,1:pver)*1.e-6_r8 !! LSSNOW (calculated in cldwat2m_micro.F90, passed to stratiform.F90) - reff_cosp(1:ncol,1:pver,5) = cv_reffliq(1:ncol,1:pver)*1.e-6_r8 !! CVCLIQ (calculated in stratiform.F90, not actually used in radiation) - reff_cosp(1:ncol,1:pver,6) = cv_reffice(1:ncol,1:pver)*1.e-6_r8 !! CVCICE (calculated in stratiform.F90, not actually used in radiation) - reff_cosp(1:ncol,1:pver,7) = ls_reffrain(1:ncol,1:pver)*1.e-6_r8 !! CVRAIN (same as stratiform per Andrew) - reff_cosp(1:ncol,1:pver,8) = ls_reffsnow(1:ncol,1:pver)*1.e-6_r8 !! CVSNOW (same as stratiform per Andrew) - reff_cosp(1:ncol,1:pver,9) = 0._r8 !! LSGRPL (using radar default reff) + + !! The specification of reff_cosp now follows e-mail discussion with Yuying in January 2011. + !! The values from the physics buffer are in microns... convert to meters for COSP. + reff_cosp(:,:,I_LSCLIQ) = rel(:ncol,ktop:pver)*1.e-6_r8 + reff_cosp(:,:,I_LSCICE) = rei(:ncol,ktop:pver)*1.e-6_r8 + reff_cosp(:,:,I_LSRAIN) = ls_reffrain(:ncol,ktop:pver)*1.e-6_r8 + reff_cosp(:,:,I_LSSNOW) = ls_reffsnow(:ncol,ktop:pver)*1.e-6_r8 + reff_cosp(:,:,I_CVCLIQ) = cv_reffliq(:ncol,ktop:pver)*1.e-6_r8 + reff_cosp(:,:,I_CVCICE) = cv_reffice(:ncol,ktop:pver)*1.e-6_r8 + reff_cosp(:,:,I_CVRAIN) = ls_reffrain(:ncol,ktop:pver)*1.e-6_r8 !! same as stratiform per Andrew + reff_cosp(:,:,I_CVSNOW) = ls_reffsnow(:ncol,ktop:pver)*1.e-6_r8 !! same as stratiform per Andrew + reff_cosp(:,:,I_LSGRPL) = 0._r8 !! using radar default reff - !! Need code below for when effective radius is fillvalue, and you multiply it by 1.e-6 to convert units, and value becomes no longer fillvalue. - !! Here, we set it back to zero. - where (rel(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,1) = 0._r8 - end where - where (rei(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,2) = 0._r8 - end where - where (ls_reffrain(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,3) = 0._r8 - end where - where (ls_reffsnow(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,4) = 0._r8 - end where - where (cv_reffliq(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,5) = 0._r8 - end where - where (cv_reffice(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,6) = 0._r8 - end where - where (ls_reffrain(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,7) = 0._r8 - end where - where (ls_reffsnow(1:ncol,1:pver) .eq. R_UNDEF) - reff_cosp(1:ncol,1:pver,8) = 0._r8 - end where - - !! Make sure interpolated values are not less than 0 - COSP was complaining and resetting small negative values to zero. - !! ----- WARNING: COSP_CHECK_INPUT_2D: minimum value of rain_ls set to: 0.000000000000000 - !! So I set negative values to zero here... - do k=1,pver - do i=1,ncol - if (rain_ls_interp(i,k) .lt. 0._r8) then - rain_ls_interp(i,k)=0._r8 + !! Make sure interpolated values are not less than 0 + do k = 1, nlay + do i = 1, ncol + if (rain_ls_interp(i,k) < 0._r8) then + rain_ls_interp(i,k) = 0._r8 end if - if (snow_ls_interp(i,k) .lt. 0._r8) then - snow_ls_interp(i,k)=0._r8 + if (snow_ls_interp(i,k) < 0._r8) then + snow_ls_interp(i,k) = 0._r8 end if - if (rain_cv_interp(i,k) .lt. 0._r8) then - rain_cv_interp(i,k)=0._r8 + if (rain_cv_interp(i,k) < 0._r8) then + rain_cv_interp(i,k) = 0._r8 end if - if (snow_cv_interp(i,k) .lt. 0._r8) then - snow_cv_interp(i,k)=0._r8 + if (snow_cv_interp(i,k) < 0._r8) then + snow_cv_interp(i,k) = 0._r8 end if end do end do - ! 5) assign optical depths and emissivities needed for isccp simulator - cld_swtau(1:ncol,1:pver) = cld_swtau_in(1:ncol,1:pver) - - ! initialize cosp inputs - dtau_s(1:ncol,1:pver) = 0._r8 - dtau_c(1:ncol,1:pver) = 0._r8 - dtau_s_snow(1:ncol,1:pver) = 0._r8 - dem_s(1:ncol,1:pver) = 0._r8 - dem_c(1:ncol,1:pver) = 0._r8 - dem_s_snow(1:ncol,1:pver) = 0._r8 - - ! assign values - ! NOTES: - ! 1) CAM4 assumes same radiative properties for stratiform and convective clouds, - ! (see ISCCP_CLOUD_TYPES subroutine call in cloudsimulator.F90) - ! I presume CAM5 is doing the same thing based on the ISCCP simulator calls within RRTM's radiation.F90 - ! 2) COSP wants in-cloud values. CAM5 values cld_swtau are in-cloud. - ! 3) snow_tau_in and snow_emis_in are passed without modification to COSP - dtau_s(1:ncol,1:pver) = cld_swtau(1:ncol,1:pver) ! mean 0.67 micron optical depth of stratiform (in-cloud) - dtau_c(1:ncol,1:pver) = cld_swtau(1:ncol,1:pver) ! mean 0.67 micron optical depth of convective (in-cloud) - dem_s(1:ncol,1:pver) = emis(1:ncol,1:pver) ! 10.5 micron longwave emissivity of stratiform (in-cloud) - dem_c(1:ncol,1:pver) = emis(1:ncol,1:pver) ! 10.5 micron longwave emissivity of convective (in-cloud) - dem_s_snow(1:ncol,1:pver) = snow_emis_in(1:ncol,1:pver) ! 10.5 micron grid-box mean optical depth of stratiform snow - dtau_s_snow(1:ncol,1:pver) = snow_tau_in(1:ncol,1:pver) ! 0.67 micron grid-box mean optical depth of stratiform snow + ! assign optical depths and emissivities + ! CAM4 assumes same radiative properties for stratiform and convective clouds, + ! (see ISCCP_CLOUD_TYPES subroutine call in cloudsimulator.F90) + ! Assume CAM5 is doing the same thing based on the ISCCP simulator calls within RRTM's radiation.F90 + ! COSP wants in-cloud values. CAM5 values cld_swtau are in-cloud. + ! snow_tau_in and snow_emis_in are passed without modification to COSP + dtau_s = cld_swtau_in(:ncol,ktop:pver) + dtau_c = cld_swtau_in(:ncol,ktop:pver) + dtau_s_snow = snow_tau_in(:ncol,ktop:pver) + dem_s = emis(:ncol,ktop:pver) + dem_c = emis(:ncol,ktop:pver) + dem_s_snow = snow_emis_in(:ncol,ktop:pver) ! ###################################################################################### ! Compute sunlit flag. If cosp_runall=.true., then run on all points. @@ -1922,32 +1678,22 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn if (cosp_runall) then cam_sunlit(:) = 1 nSunLit = ncol - nNoSunLit = 0 else nSunLit = 0 - nNoSunLit = 0 do i=1,ncol if ((coszrs(i) > 0.0_r8) .and. (run_cosp(i,lchnk))) then cam_sunlit(i) = 1 nSunLit = nSunLit+1 - else - nNoSunLit = nNoSunlit+1 endif enddo endif call t_stopf("init_and_stuff") - ! ###################################################################################### - ! ###################################################################################### - ! END TRANSLATE CAM VARIABLES TO COSP INPUT VARIABLES - ! ###################################################################################### - ! ###################################################################################### - ! ###################################################################################### ! Construct COSP output derived type. ! ###################################################################################### call t_startf("construct_cosp_outputs") - call construct_cosp_outputs(ncol,nscol_cosp,pver,Nlvgrid,0,cospOUT) + call construct_cosp_outputs(ncol, nscol_cosp, nlay, Nlvgrid, 0, cospOUT) call t_stopf("construct_cosp_outputs") ! ###################################################################################### @@ -1955,44 +1701,43 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! ###################################################################################### ! Model state call t_startf("construct_cospstateIN") - call construct_cospstateIN(ncol,pver,0,cospstateIN) - cospstateIN%lat = lat_cosp(1:ncol) - cospstateIN%lon = lon_cosp(1:ncol) - cospstateIN%at = state%t(1:ncol,1:pver) - cospstateIN%qv = q(1:ncol,1:pver) - cospstateIN%o3 = o3(1:ncol,1:pver) - cospstateIN%sunlit = cam_sunlit(1:ncol) - cospstateIN%skt = cam_in%ts(1:ncol) - cospstateIN%land = landmask(1:ncol) - cospstateIN%pfull = state%pmid(1:ncol,1:pver) - cospstateIN%phalf(1:ncol,1) = 0._r8 - cospstateIN%phalf(1:ncol,2:pver+1) = pbot(1:ncol,pver:1:-1) - cospstateIN%hgt_matrix = zmid(1:ncol,1:pver) - cospstateIN%hgt_matrix_half(1:ncol,pver+1) = 0._r8 - cospstateIN%hgt_matrix_half(1:ncol,1:pver) = zbot(1:ncol,pver:1:-1) - cospstateIN%surfelev(1:ncol) = zbot(1:ncol,1) + + call construct_cospstateIN(ncol, nlay, 0, cospstateIN) + + ! convert to degrees. Lat in range [-90,..,90], Lon in range [0,..,360] + cospstateIN%lat = state%lat(:ncol)*180._r8/pi + cospstateIN%lon = state%lon(:ncol)*180._r8/pi + cospstateIN%at = state%t(:ncol,ktop:pver) + cospstateIN%qv = q(:ncol,ktop:pver) + cospstateIN%o3 = o3(:ncol,ktop:pver) + cospstateIN%sunlit = cam_sunlit(:ncol) + cospstateIN%skt = cam_in%ts(:ncol) + cospstateIN%land = landmask + cospstateIN%pfull = state%pmid(:ncol,ktop:pver) + cospstateIN%phalf(:,1) = 0._r8 + cospstateIN%phalf(:,2:nlay+1) = state%pint(1:ncol,ktop+1:pverp) + cospstateIN%hgt_matrix = zmid + cospstateIN%hgt_matrix_half(:ncol,nlay+1) = 0._r8 + cospstateIN%hgt_matrix_half(:ncol,:nlay) = zbot + cospstateIN%surfelev = zbot(:ncol,nlay) call t_stopf("construct_cospstateIN") ! Optical inputs call t_startf("construct_cospIN") - call construct_cospIN(ncol,nscol_cosp,pver,cospIN) - cospIN%emsfc_lw = emsfc_lw + call construct_cospIN(ncol, nscol_cosp, nlay, cospIN) + cospIN%emsfc_lw = emsfc_lw if (lradar_sim) cospIN%rcfg_cloudsat = rcfg_cs(lchnk) call t_stopf("construct_cospIN") - ! *NOTE* Fields passed into subsample_and_optics are ordered from TOA-2-SFC. call t_startf("subsample_and_optics") - call subsample_and_optics(ncol,pver,nscol_cosp,nhydro,overlap, & - use_precipitation_fluxes,lidar_ice_type,sd_cs(lchnk),cld(1:ncol,1:pver),& - concld(1:ncol,1:pver),rain_ls_interp(1:ncol,1:pver), & - snow_ls_interp(1:ncol,1:pver),grpl_ls_interp(1:ncol,1:pver), & - rain_cv_interp(1:ncol,1:pver),snow_cv_interp(1:ncol,1:pver), & - mr_lsliq(1:ncol,1:pver),mr_lsice(1:ncol,1:pver), & - mr_ccliq(1:ncol,1:pver),mr_ccice(1:ncol,1:pver), & - reff_cosp(1:ncol,1:pver,:),dtau_c(1:ncol,1:pver), & - dtau_s(1:ncol,1:pver),dem_c(1:ncol,1:pver), & - dem_s(1:ncol,1:pver),dtau_s_snow(1:ncol,1:pver), & - dem_s_snow(1:ncol,1:pver),state%ps(1:ncol),cospstateIN,cospIN) + call subsample_and_optics( & + ncol, nlay, nscol_cosp, nhydro, overlap, & + use_precipitation_fluxes, lidar_ice_type,sd_cs(lchnk), & + cld(:ncol,ktop:pver), concld(:ncol,ktop:pver), & + rain_ls_interp, snow_ls_interp, grpl_ls_interp, rain_cv_interp, & + snow_cv_interp, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, & + reff_cosp, dtau_c, dtau_s ,dem_c, dem_s, dtau_s_snow, & + dem_s_snow, state%ps(:ncol), cospstateIN, cospIN) call t_stopf("subsample_and_optics") ! ###################################################################################### @@ -2030,7 +1775,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn call outfld('ZLEV_HALF_COSP', cospstateIN%hgt_matrix_half, ncol,lchnk) call outfld('T_COSP', cospstateIN%at, ncol,lchnk) call outfld('RH_COSP', cospstateIN%qv, ncol,lchnk) - call outfld('Q_COSP', q(1:ncol,1:pver), ncol,lchnk) ! 3D outputs, but first compress to 2D do i=1,ncol @@ -2146,18 +1890,18 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ! ###################################################################################### call t_startf("output_copying") if (allocated(cospIN%frac_out)) & - frac_out(1:ncol,1:nscol_cosp,1:nlay) = cospIN%frac_out ! frac_out (time,height_mlev,column,profile) + frac_out(1:ncol,1:nscol_cosp,1:nlay) = cospIN%frac_out ! Cloudsat if (lradar_sim) then - cfad_dbze94(1:ncol,1:CLOUDSAT_DBZE_BINS,1:nht_cosp) = cospOUT%cloudsat_cfad_ze ! cfad_dbze94 (time,height,dbze,profile) - dbze94(1:ncol,1:nscol_cosp,1:nlay) = cospOUT%cloudsat_Ze_tot ! dbze94 (time,height_mlev,column,profile) - cldtot_cs(1:ncol) = 0._r8!cospOUT%cloudsat_radar_tcc ! CAM version of cltradar (time,profile) ! NOT COMPUTED IN COSP2 - cldtot_cs2(1:ncol) = 0._r8!cospOUT%cloudsat_radar_tcc2 ! CAM version of cltradar2 (time,profile) ! NOT COMPUTED IN COSP2 + cfad_dbze94(1:ncol,1:CLOUDSAT_DBZE_BINS,1:nht_cosp) = cospOUT%cloudsat_cfad_ze + dbze94(1:ncol,1:nscol_cosp,1:nlay) = cospOUT%cloudsat_Ze_tot + cldtot_cs(1:ncol) = 0._r8 + cldtot_cs2(1:ncol) = 0._r8 ! *NOTE* These two fields are joint-simulator products, but in CAM they are controlled ! by the radar simulator control. - cldtot_calcs(1:ncol) = cospOUT%radar_lidar_tcc ! CAM version of cltlidarradar (time,profile) - cld_cal_notcs(1:ncol,1:nht_cosp) = cospOUT%lidar_only_freq_cloud ! CAM version of clcalipso2 (time,height,profile) + cldtot_calcs(1:ncol) = cospOUT%radar_lidar_tcc + cld_cal_notcs(1:ncol,1:nht_cosp) = cospOUT%lidar_only_freq_cloud ! Cloudsat near-surface precipitation diagnostics ptcloudsatflag0(1:ncol) = cospOUT%cloudsat_precip_cover(:,1) @@ -2172,64 +1916,56 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn ptcloudsatflag9(1:ncol) = cospOUT%cloudsat_precip_cover(:,10) cloudsatpia(1:ncol) = cospOUT%cloudsat_pia - ! Output the mixing-ratio for all hydrometeor types in Cloudsat near-surface precipitation diagnostics - ! *NOTE* These fields are simply the native CAM mixing-ratios for each hydrometeor type used in the - ! CAM6 microphysics scheme, interpolated to the same vertical grid used by the Cloudsat - ! simulator. These fields are not part of the radar simulator standard output, as these fields - ! are entirely dependent on the host models microphysics, not the retrieval. - - endif ! CALIPSO if (llidar_sim) then - cldlow_cal(1:ncol) = cospOUT%calipso_cldlayer(:,1) ! CAM version of cllcalipso (time,profile) - cldmed_cal(1:ncol) = cospOUT%calipso_cldlayer(:,2) ! CAM version of clmcalipso (time,profile) - cldhgh_cal(1:ncol) = cospOUT%calipso_cldlayer(:,3) ! CAM version of clhcalipso (time,profile) - cldtot_cal(1:ncol) = cospOUT%calipso_cldlayer(:,4) ! CAM version of cltcalipso (time,profile) - cldlow_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,1) ! CAM version of cllcalipsoice !+cosp1.4 - cldmed_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,1) ! CAM version of clmcalipsoice - cldhgh_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,1) ! CAM version of clhcalipsoice - cldtot_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,1) ! CAM version of cltcalipsoice - cldlow_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,2) ! CAM version of cllcalipsoliq - cldmed_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,2) ! CAM version of clmcalipsoliq - cldhgh_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,2) ! CAM version of clhcalipsoliq - cldtot_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,2) ! CAM version of cltcalipsoliq - cldlow_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,3) ! CAM version of cllcalipsoun - cldmed_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,3) ! CAM version of clmcalipsoun - cldhgh_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,3) ! CAM version of clhcalipsoun - cldtot_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,3) ! CAM version of cltcalipsoun, !+cosp1.4 - cld_cal_ice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,1) ! CAM version of clcalipsoice !+cosp1.4 - cld_cal_liq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,2) ! CAM version of clcalipsoliq - cld_cal_un(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,3) ! CAM version of clcalipsoun - cld_cal_tmp(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,1) ! CAM version of clcalipsotmp - cld_cal_tmpliq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,2) ! CAM version of clcalipsotmpice - cld_cal_tmpice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,3) ! CAM version of clcalipsotmpliq - cld_cal_tmpun(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,4) ! CAM version of clcalipsotmpun, !+cosp1.4 - cld_cal(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcld(:,1:nht_cosp) ! CAM version of clcalipso (time,height,profile) - mol532_cal(1:ncol,1:nlay) = cospOUT%calipso_beta_mol ! CAM version of beta_mol532 (time,height_mlev,profile) - atb532(1:ncol,1:nscol_cosp,1:nlay)= cospOUT%calipso_beta_tot ! atb532 (time,height_mlev,column,profile) - cfad_lidarsr532(1:ncol,1:nsr_cosp,1:nht_cosp) = cospOUT%calipso_cfad_sr(:,:,:) ! cfad_lidarsr532 (time,height,scat_ratio,profile) - ! PARASOL. In COSP2, the Parasol simulator is independent of the calipso simulator. - refl_parasol(1:ncol,1:nsza_cosp) = cospOUT%parasolGrid_refl ! CAM version of parasolrefl (time,sza,profile) + cldlow_cal(1:ncol) = cospOUT%calipso_cldlayer(:,1) + cldmed_cal(1:ncol) = cospOUT%calipso_cldlayer(:,2) + cldhgh_cal(1:ncol) = cospOUT%calipso_cldlayer(:,3) + cldtot_cal(1:ncol) = cospOUT%calipso_cldlayer(:,4) + cldlow_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,1) + cldmed_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,1) + cldhgh_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,1) + cldtot_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,1) + cldlow_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,2) + cldmed_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,2) + cldhgh_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,2) + cldtot_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,2) + cldlow_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,3) + cldmed_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,3) + cldhgh_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,3) + cldtot_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,3) + cld_cal_ice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,1) + cld_cal_liq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,2) + cld_cal_un(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,3) + cld_cal_tmp(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,1) + cld_cal_tmpliq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,2) + cld_cal_tmpice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,3) + cld_cal_tmpun(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,4) + cld_cal(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcld(:,1:nht_cosp) + mol532_cal(1:ncol,1:nlay) = cospOUT%calipso_beta_mol + atb532(1:ncol,1:nscol_cosp,1:nlay)= cospOUT%calipso_beta_tot + cfad_lidarsr532(1:ncol,1:nsr_cosp,1:nht_cosp) = cospOUT%calipso_cfad_sr(:,:,:) + refl_parasol(1:ncol,1:nsza_cosp) = cospOUT%parasolGrid_refl endif ! ISCCP if (lisccp_sim) then - clisccp2(1:ncol,1:ntau_cosp,1:nprs_cosp) = cospOUT%isccp_fq ! CAM version of clisccp2 (time,tau,plev,profile) - tau_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxtau ! CAM version of boxtauisccp (time,column,profile) - cldptop_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxptop ! CAM version of boxptopisccp (time,column,profile) - cldtot_isccp(1:ncol) = cospOUT%isccp_totalcldarea ! CAM version of tclisccp (time, profile) - meanptop_isccp(1:ncol) = cospOUT%isccp_meanptop ! CAM version of ctpisccp (time, profile) - meantau_isccp(1:ncol) = cospOUT%isccp_meantaucld ! CAM version of meantbisccp (time, profile) - meancldalb_isccp(1:ncol) = cospOUT%isccp_meanalbedocld ! CAM version of albisccp (time, profile) - meantb_isccp(1:ncol) = cospOUT%isccp_meantb ! CAM version of meantbisccp (time, profile) - meantbclr_isccp(1:ncol) = cospOUT%isccp_meantbclr ! CAM version of meantbclrisccp (time, profile) + clisccp2(1:ncol,1:ntau_cosp,1:nprs_cosp) = cospOUT%isccp_fq + tau_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxtau + cldptop_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxptop + cldtot_isccp(1:ncol) = cospOUT%isccp_totalcldarea + meanptop_isccp(1:ncol) = cospOUT%isccp_meanptop + meantau_isccp(1:ncol) = cospOUT%isccp_meantaucld + meancldalb_isccp(1:ncol) = cospOUT%isccp_meanalbedocld + meantb_isccp(1:ncol) = cospOUT%isccp_meantb + meantbclr_isccp(1:ncol) = cospOUT%isccp_meantbclr endif ! MISR if (lmisr_sim) then - clMISR(1:ncol,1:ntau_cosp,1:nhtmisr_cosp) = cospOUT%misr_fq ! CAM version of clMISR (time,tau,CTH_height_bin,profile) + clMISR(1:ncol,1:ntau_cosp,1:nhtmisr_cosp) = cospOUT%misr_fq endif ! MODIS @@ -2256,46 +1992,39 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn clrlmodis(1:ncol,1:ntau_cosp_modis,1:numMODISReffLiqBins) = cospOUT%modis_Optical_Thickness_vs_ReffLIQ endif - ! Use high-dimensional output to populate CAM collapsed output variables - ! see above for mixed dimension definitions - ! i am using the convention of starting vertical coordinates at the surface, up to down, COSP convention, not CAM. + ! Use COSP output to populate CAM collapsed output variables do i=1,ncol if (lradar_sim) then - ! CAM cfad_dbze94 (time,height,dbze,profile) do ih=1,nht_cosp do id=1,CLOUDSAT_DBZE_BINS ihd=(ih-1)*CLOUDSAT_DBZE_BINS+id - cfad_dbze94_cs(i,ihd) = cfad_dbze94(i,id,ih) ! cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS) + cfad_dbze94_cs(i,ihd) = cfad_dbze94(i,id,ih) end do end do - ! CAM dbze94 (time,height_mlev,column,profile) do ihml=1,nlay do isc=1,nscol_cosp ihsc=(ihml-1)*nscol_cosp+isc - dbze_cs(i,ihsc) = dbze94(i,isc,ihml) ! dbze_cs(pcols,pver*nscol_cosp) + dbze_cs(i,ihsc) = dbze94(i,isc,ihml) end do end do endif if (llidar_sim) then - ! CAM cfad_lidarsr532 (time,height,scat_ratio,profile) do ih=1,nht_cosp do is=1,nsr_cosp ihs=(ih-1)*nsr_cosp+is - cfad_sr532_cal(i,ihs) = cfad_lidarsr532(i,is,ih) ! cfad_sr532_cal(pcols,nht_cosp*nsr_cosp) + cfad_sr532_cal(i,ihs) = cfad_lidarsr532(i,is,ih) end do end do - ! CAM atb532 (time,height_mlev,column,profile) FIX do ihml=1,nlay do isc=1,nscol_cosp ihsc=(ihml-1)*nscol_cosp+isc - atb532_cal(i,ihsc) = atb532(i,isc,ihml) ! atb532_cal(pcols,nht_cosp*nscol_cosp) + atb532_cal(i,ihsc) = atb532(i,isc,ihml) end do end do endif if (lmisr_sim) then - ! CAM clMISR (time,tau,CTH_height_bin,profile) do ihm=1,nhtmisr_cosp do it=1,ntau_cosp ihmt=(ihm-1)*ntau_cosp+it @@ -2305,21 +2034,18 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn endif if (lmodis_sim) then - ! CAM clmodis do ip=1,nprs_cosp do it=1,ntau_cosp_modis ipt=(ip-1)*ntau_cosp_modis+it clmodis_cam(i,ipt) = clmodis(i,it,ip) end do end do - ! CAM clrimodis do ip=1,numMODISReffIceBins do it=1,ntau_cosp_modis ipt=(ip-1)*ntau_cosp_modis+it clrimodis_cam(i,ipt) = clrimodis(i,it,ip) end do end do - ! CAM clrlmodis do ip=1,numMODISReffLiqBins do it=1,ntau_cosp_modis ipt=(ip-1)*ntau_cosp_modis+it @@ -2332,7 +2058,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn do ihml=1,nlay do isc=1,nscol_cosp ihsc=(ihml-1)*nscol_cosp+isc - scops_out(i,ihsc) = frac_out(i,isc,ihml) ! scops_out(pcols,nht_cosp*nscol_cosp) + scops_out(i,ihsc) = frac_out(i,isc,ihml) end do end do end do @@ -2462,40 +2188,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn end where call outfld('CLD_CAL_TMPUN',cld_cal_tmpun ,pcols,lchnk) !! !+cosp1.4 - ! Opaque cloud diagnostics -! call outfld('CLDOPQ_CAL', cldopaq_cal, pcols, lchnk) -! call outfld('CLDTHN_CAL', cldthin_cal, pcols, lchnk) -! call outfld('CLDZOPQ_CAL', cldopaqz_cal, pcols, lchnk) -! call outfld('CLDOPQ_CAL_TMP', cldopaq_cal_temp, pcols, lchnk) -! call outfld('CLDTHN_CAL_TMP', cldthin_cal_temp, pcols, lchnk) -! call outfld('CLDZOPQ_CAL_TMP', cldzopaq_cal_temp, pcols, lchnk) -! call outfld('CLDOPQ_CAL_Z', cldopaq_cal_z, pcols, lchnk) -! call outfld('CLDTHN_CAL_Z', cldthin_cal_z, pcols, lchnk) -! call outfld('CLDTHN_CAL_EMIS', cldthin_cal_emis, pcols, lchnk) -! call outfld('CLDOPQ_CAL_SE', cldopaq_cal_se, pcols, lchnk) -! call outfld('CLDTHN_CAL_SE', cldthin_cal_se, pcols, lchnk) -! call outfld('CLDZOPQ_CAL_SE', cldzopaq_cal_se, pcols, lchnk) -! ! -! where (cldopaq_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF) -! cldopaq_cal_2d(:ncol,:nht_cosp) = 0.0_r8 -! end where -! call outfld('CLDOPQ_CAL_2D', cldopaq_cal_2d, pcols, lchnk) -! ! -! where (cldthin_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF) -! cldthin_cal_2d(:ncol,:nht_cosp) = 0.0_r8 -! end where -! call outfld('CLDTHN_CAL_2D', cldthin_cal_2d, pcols, lchnk) -! ! -! where (cldzopaq_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF) -! cldzopaq_cal_2d(:ncol,:nht_cosp) = 0.0_r8 -! end where -! call outfld('CLDZOPQ_CAL_2D', cldzopaq_cal_2d, pcols, lchnk) -! ! -! where (opacity_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF) -! opacity_cal_2d(:ncol,:nht_cosp) = 0.0_r8 -! end where -! call outfld('OPACITY_CAL_2D', opacity_cal_2d, pcols, lchnk) - end if ! RADAR SIMULATOR OUTPUTS @@ -2994,13 +2686,6 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, ! For near-surface diagnostics, we only need the frozen fraction at one layer. cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,cloudsat_preclvl) - ! Regrid preipitation mixing-ratios to statistical grid. - !allocate(tempStatGrid(nPoints,ncol,Nlvgrid)) - !tempStatGrid(:,:,:,:) = 0._wp - !call cosp_change_vertical_grid(Npoints, ncol, pver, cospstateIN%hgt_matrix(:,pver:1:-1), & - ! cospstateIN%hgt_matrix_half(:,pver:1:-1), mr_hydro(:,:,:,LSGRPL), & - ! Nlvgrid,vgrid_zl(Nlvgrid:1:-1), vgrid_zu(Nlvgrid:1:-1), tempStatGrid) - ! endif call t_stopf("cloudsat_optics") @@ -3185,15 +2870,31 @@ subroutine construct_cospstateIN(npoints,nlevels,nchan,y) nlevels, & ! Number of vertical levels nchan ! Number of channels ! Outputs - type(cosp_column_inputs),intent(out) :: y + type(cosp_column_inputs),intent(out) :: y - allocate(y%sunlit(npoints),y%skt(npoints),y%land(npoints),y%at(npoints,nlevels), & - y%pfull(npoints,nlevels),y%phalf(npoints,nlevels+1),y%qv(npoints,nlevels), & - y%o3(npoints,nlevels),y%hgt_matrix(npoints,nlevels),y%u_sfc(npoints), & - y%v_sfc(npoints),y%lat(npoints),y%lon(nPoints),y%emis_sfc(nchan), & - y%cloudIce(nPoints,nLevels),y%cloudLiq(nPoints,nLevels),y%surfelev(nPoints),& - y%fl_snow(nPoints,nLevels),y%fl_rain(nPoints,nLevels),y%seaice(npoints), & - y%tca(nPoints,nLevels),y%hgt_matrix_half(npoints,nlevels+1)) + allocate( & + y%sunlit(npoints), & + y%at(npoints,nlevels), & + y%pfull(npoints,nlevels), & + y%phalf(npoints,nlevels+1), & + y%qv(npoints,nlevels), & + y%hgt_matrix(npoints,nlevels), & + y%hgt_matrix_half(npoints,nlevels+1), & + y%land(npoints), & + y%skt(npoints), & + y%surfelev(nPoints), & + y%emis_sfc(nchan), & + y%u_sfc(npoints), & + y%v_sfc(npoints), & + y%seaice(npoints), & + y%lat(npoints), & + y%lon(nPoints), & + y%o3(npoints,nlevels), & + y%tca(nPoints,nLevels), & + y%cloudIce(nPoints,nLevels), & + y%cloudLiq(nPoints,nLevels), & + y%fl_rain(nPoints,nLevels), & + y%fl_snow(nPoints,nLevels) ) end subroutine construct_cospstateIN ! ###################################################################################### @@ -3274,17 +2975,8 @@ subroutine construct_cosp_outputs(Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x) allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6)) allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5)) allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6)) - ! These 2 outputs are part of the calipso output type, but are not controlled by an - ! logical switch in the output namelist, so if all other fields are on, then allocate allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels)) allocate(x%calipso_temp_tot(Npoints,Nlevels)) - ! Calipso opaque cloud diagnostics -! allocate(x%calipso_cldtype(Npoints,LIDAR_NTYPE)) -! allocate(x%calipso_cldtypetemp(Npoints,LIDAR_NTYPE)) -! allocate(x%calipso_cldtypemeanz(Npoints,2)) -! allocate(x%calipso_cldtypemeanzse(Npoints,3)) -! allocate(x%calipso_cldthinemis(Npoints)) -! allocate(x%calipso_lidarcldtype(Npoints,Nlvgrid,LIDAR_NTYPE+1)) endif ! PARASOL From f3000de68a87d6a1ba0ad9e6d0c1f0a3f35ee166 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 10 Apr 2024 17:21:58 -0400 Subject: [PATCH 03/17] add coordinate trop_pref --- src/physics/cam/cospsimulator_intr.F90 | 1 + src/physics/cam/ref_pres.F90 | 25 +++++++++++++++++++++++-- src/utils/hycoef.F90 | 6 +++++- 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 0606d696b2..7ef56bd4e3 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -811,6 +811,7 @@ subroutine cospsimulator_intr_init() 'T_COSP', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('RH_COSP', (/ 'lev'/), 'I','percent', & 'RH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('TAU_067', (/'cosp_scol','lev '/), 'I','1', & 'Subcolumn 0.67micron optical depth', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('EMISS_11', (/'cosp_scol','lev '/), 'I','1', & diff --git a/src/physics/cam/ref_pres.F90 b/src/physics/cam/ref_pres.F90 index f0d5994b81..ce1a1b0afb 100644 --- a/src/physics/cam/ref_pres.F90 +++ b/src/physics/cam/ref_pres.F90 @@ -11,8 +11,11 @@ module ref_pres ! !-------------------------------------------------------------------------- -use shr_kind_mod, only: r8=>shr_kind_r8 -use ppgrid, only: pver, pverp +use shr_kind_mod, only: r8=>shr_kind_r8 +use ppgrid, only: pver, pverp +use cam_history_support, only: add_vert_coord +use cam_logfile, only: iulog +use error_messages, only: alloc_err implicit none public @@ -49,6 +52,10 @@ module ref_pres logical, protected :: do_molec_diff = .false. integer, protected :: nbot_molec = 0 +! Data for the trop_pref coordinate. It is the target of a pointer in a hist_coord_t +! object in the cam_history_support module. It is associated by the call to add_vert_coord. +real(r8), private, allocatable, target :: trop_pref(:) + !==================================================================================== contains !==================================================================================== @@ -111,6 +118,11 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in) real(r8), intent(in) :: pref_edge_in(:) ! reference pressure at layer edges (Pa) real(r8), intent(in) :: pref_mid_in(:) ! reference pressure at layer midpoints (Pa) integer, intent(in) :: num_pr_lev_in ! number of top levels using pure pressure representation + + ! local variables + integer :: nlev + integer :: istat + character(len=*), parameter :: sub = 'ref_pres_init' !--------------------------------------------------------------------------- pref_edge = pref_edge_in @@ -137,6 +149,15 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in) top=.false.) end if + ! Add vertical coordinate to history file for use with outputs that are only + ! computed in the subdomain bounded by the top of troposphere clouds. + nlev = pver - trop_cloud_top_lev + 1 + allocate(trop_pref(nlev), stat=istat) + call alloc_err(istat, sub, 'trop_pref', nlev) + trop_pref = pref_mid(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa + call add_vert_coord('trop_pref', nlev, 'troposphere reference pressures', & + 'hPa', trop_pref, positive='down') + end subroutine ref_pres_init !==================================================================================== diff --git a/src/utils/hycoef.F90 b/src/utils/hycoef.F90 index 2abfbb2ec7..241abf5c7e 100644 --- a/src/utils/hycoef.F90 +++ b/src/utils/hycoef.F90 @@ -21,6 +21,10 @@ module hycoef ! interfaces p(k) = hyai(k)*ps0 + hybi(k)*ps ! midpoints p(k) = hyam(k)*ps0 + hybm(k)*ps ! +! Note: Module data with a target attribute are targets of pointers in hist_coord_t +! objects in the cam_history_support module. They are associated by the calls +! to add_hist_coord and add_vert_coord +! !----------------------------------------------------------------------- real(r8), public, target :: hyai(plevp) ! ps0 component of hybrid coordinate - interfaces @@ -41,7 +45,7 @@ module hycoef real(r8), public, protected :: ps0 = 1.0e5_r8 ! Base state surface pressure (pascals) real(r8), public, protected :: psr = 1.0e5_r8 ! Reference surface pressure (pascals) #endif -real(r8), target :: alev(plev) ! level values (pascals) for 'lev' coord +real(r8), target :: alev(plev) ! level values (hPa) for 'lev' coord real(r8), target :: ailev(plevp) ! interface level values for 'ilev' coord integer, public :: nprlev ! number of pure pressure levels at top From 6bc197bd4545635c9aba521d2b2d09b2feaea689 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 10 Apr 2024 19:53:52 -0400 Subject: [PATCH 04/17] cosp outputs use new vertical coords as appropriate --- src/physics/cam/cospsimulator_intr.F90 | 56 +++++++++++++------------- src/physics/cam/ref_pres.F90 | 14 ++++++- 2 files changed, 40 insertions(+), 30 deletions(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 7ef56bd4e3..9646f72087 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -562,9 +562,9 @@ subroutine cospsimulator_intr_init() 'PARASOL-like mono-directional reflectance ', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CFAD_SR532_CAL', (/'cosp_sr','cosp_ht'/), 'A', 'fraction', & 'Calipso Scattering Ratio CFAD (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('MOL532_CAL', (/'lev'/), 'A', 'm-1sr-1', & + call addfld('MOL532_CAL', (/'trop_pref'/), 'A', 'm-1sr-1', & 'Calipso Molecular Backscatter (532 nm) ', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('ATB532_CAL', (/'cosp_scol','lev '/), 'I', 'no_unit_log10(x)', & + call addfld('ATB532_CAL', (/'cosp_scol','trop_pref'/), 'I', 'no_unit_log10(x)', & 'Calipso Attenuated Total Backscatter (532 nm) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLD_CAL_LIQ', (/'cosp_ht'/), 'A', 'percent', & 'Calipso Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) @@ -654,7 +654,7 @@ subroutine cospsimulator_intr_init() call addfld('CLDTOT_CS2', horiz_only, 'A', 'percent', & 'Radar total cloud amount without the data for the first kilometer above surface ', & flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('DBZE_CS', (/'cosp_scol','lev '/), 'I', 'dBZe', & + call addfld('DBZE_CS', (/'cosp_scol','trop_pref'/), 'I', 'dBZe', & 'Radar dBZe (94 GHz) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) ! Cloudsat near-sfc precipitation diagnostics @@ -774,7 +774,7 @@ subroutine cospsimulator_intr_init() ! SUB-COLUMN OUTPUT if (lfrac_out) then - call addfld('SCOPS_OUT', (/'cosp_scol','lev '/), 'I', '0=nocld,1=strcld,2=cnvcld', & + call addfld('SCOPS_OUT', (/'cosp_scol','trop_pref'/), 'I', '0=nocld,1=strcld,2=cnvcld', & 'SCOPS Subcolumn output', flag_xyfill=.true., fill_value=R_UNDEF) call add_default('SCOPS_OUT',cosp_histfile_num,' ') @@ -799,46 +799,46 @@ subroutine cospsimulator_intr_init() 'PS_COSP', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('TS_COSP', horiz_only, 'I','K', & 'TS_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('P_COSP', (/ 'lev'/), 'I','Pa', & + call addfld ('P_COSP', (/ 'trop_pref'/), 'I','Pa', & 'P_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('PH_COSP', (/ 'lev'/), 'I','Pa', & + call addfld ('PH_COSP', (/ 'trop_prefi'/), 'I','Pa', & 'PH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('ZLEV_COSP', (/ 'lev'/), 'I','m', & + call addfld ('ZLEV_COSP', (/ 'trop_pref'/), 'I','m', & 'ZLEV_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('ZLEV_HALF_COSP', (/ 'lev'/), 'I','m', & + call addfld ('ZLEV_HALF_COSP', (/ 'trop_prefi'/), 'I','m', & 'ZLEV_HALF_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('T_COSP', (/ 'lev'/), 'I','K', & + call addfld ('T_COSP', (/ 'trop_pref'/), 'I','K', & 'T_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('RH_COSP', (/ 'lev'/), 'I','percent', & + call addfld ('RH_COSP', (/ 'trop_pref'/), 'I','percent', & 'RH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('TAU_067', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('TAU_067', (/'cosp_scol','trop_pref'/), 'I','1', & 'Subcolumn 0.67micron optical depth', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('EMISS_11', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('EMISS_11', (/'cosp_scol','trop_pref'/), 'I','1', & 'Subcolumn 11micron emissivity', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_fracliq', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('MODIS_fracliq', (/'cosp_scol','trop_pref'/), 'I','1', & 'Fraction of tau from liquid water', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_asym', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('MODIS_asym', (/'cosp_scol','trop_pref'/), 'I','1', & 'Asymmetry parameter (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_ssa', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('MODIS_ssa', (/'cosp_scol','trop_pref'/), 'I','1', & 'Single-scattering albedo (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CAL_betatot', (/'cosp_scol','trop_pref'/), 'I','1', & 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot_ice', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CAL_betatot_ice', (/'cosp_scol','trop_pref'/), 'I','1', & 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot_liq', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CAL_betatot_liq', (/'cosp_scol','trop_pref'/), 'I','1', & 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CAL_tautot', (/'cosp_scol','trop_pref'/), 'I','1', & 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot_ice', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CAL_tautot_ice', (/'cosp_scol','trop_pref'/), 'I','1', & 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot_liq', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CAL_tautot_liq', (/'cosp_scol','trop_pref'/), 'I','1', & 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CS_z_vol', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CS_z_vol', (/'cosp_scol','trop_pref'/), 'I','1', & 'Effective reflectivity factor (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CS_kr_vol', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CS_kr_vol', (/'cosp_scol','trop_pref'/), 'I','1', & 'Attenuation coefficient (hydro) (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CS_g_vol', (/'cosp_scol','lev '/), 'I','1', & + call addfld ('CS_g_vol', (/'cosp_scol','trop_pref'/), 'I','1', & 'Attenuation coefficient (gases) (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) call add_default('PS_COSP', cosp_histfile_aux_num,' ') @@ -1302,10 +1302,10 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & real(r8) :: clrimodis(pcols,ntau_cosp,numMODISReffIceBins) real(r8) :: clrlmodis_cam(pcols,ntau_cosp*numMODISReffLiqBins) real(r8) :: clrlmodis(pcols,ntau_cosp,numMODISReffLiqBins) - real(r8),dimension(pcols,nlay*nscol_cosp) :: & - tau067_out,emis11_out,fracliq_out,cal_betatot,cal_betatot_ice, & - cal_betatot_liq,cal_tautot,cal_tautot_ice,cal_tautot_liq,cs_gvol_out,cs_krvol_out,cs_zvol_out,& - asym34_out,ssa34_out + real(r8), dimension(pcols,nlay*nscol_cosp) :: & + tau067_out, emis11_out, fracliq_out, asym34_out, ssa34_out, & + cal_betatot,cal_betatot_ice, cal_betatot_liq, cal_tautot, cal_tautot_ice, & + cal_tautot_liq, cs_gvol_out, cs_krvol_out, cs_zvol_out type(interp_type) :: interp_wgts integer, parameter :: extrap_method = 1 ! sets extrapolation method to boundary value (1) diff --git a/src/physics/cam/ref_pres.F90 b/src/physics/cam/ref_pres.F90 index ce1a1b0afb..1ffdbc73b5 100644 --- a/src/physics/cam/ref_pres.F90 +++ b/src/physics/cam/ref_pres.F90 @@ -55,6 +55,7 @@ module ref_pres ! Data for the trop_pref coordinate. It is the target of a pointer in a hist_coord_t ! object in the cam_history_support module. It is associated by the call to add_vert_coord. real(r8), private, allocatable, target :: trop_pref(:) +real(r8), private, allocatable, target :: trop_prefi(:) !==================================================================================== contains @@ -149,15 +150,24 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in) top=.false.) end if - ! Add vertical coordinate to history file for use with outputs that are only + ! Add vertical coordinates to history file for use with outputs that are only ! computed in the subdomain bounded by the top of troposphere clouds. nlev = pver - trop_cloud_top_lev + 1 + allocate(trop_pref(nlev), stat=istat) call alloc_err(istat, sub, 'trop_pref', nlev) - trop_pref = pref_mid(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa + trop_pref = pref_mid(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa + call add_vert_coord('trop_pref', nlev, 'troposphere reference pressures', & 'hPa', trop_pref, positive='down') + allocate(trop_prefi(nlev+1), stat=istat) + call alloc_err(istat, sub, 'trop_prefi', nlev) + trop_prefi = pref_edge(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa + + call add_vert_coord('trop_prefi', nlev+1, 'troposphere reference pressures (interfaces)', & + 'hPa', trop_prefi, positive='down') + end subroutine ref_pres_init !==================================================================================== From 8582549f580d957657cbc3dcb6e6a42ca5360b14 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 11 Apr 2024 11:41:26 -0400 Subject: [PATCH 05/17] merge cam/physpkg.F90 changes to cam_dev/physpkg.F90 --- src/physics/cam_dev/physpkg.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index 46805c150e..c5fb88c754 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -143,7 +143,6 @@ subroutine phys_register use aircraft_emit, only: aircraft_emit_register use cam_diagnostics, only: diag_register use cloud_diagnostics, only: cloud_diagnostics_register - use cospsimulator_intr, only: cospsimulator_intr_register use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not use radheat, only: radheat_register use subcol, only: subcol_register @@ -302,9 +301,6 @@ subroutine phys_register call cloud_diagnostics_register call radheat_register - ! COSP - call cospsimulator_intr_register - ! vertical diffusion call vd_register() else From dbf15642ea21dd2410784dcc54dcb766ccfd5de1 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 12 Apr 2024 10:05:05 -0400 Subject: [PATCH 06/17] address compiler messages for cospsimulator_intr --- src/physics/cam/cospsimulator_intr.F90 | 39 ++++++-------------------- 1 file changed, 8 insertions(+), 31 deletions(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 9646f72087..b15266dc16 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -165,10 +165,8 @@ module cospsimulator_intr ! Variables for COSP input related to radar simulator real(r8) :: radar_freq = 94.0_r8 ! CloudSat radar frequency (GHz) (94.0) integer :: surface_radar = 0 ! surface=1, spaceborne=0 (0) - integer :: use_mie_tables = 0 ! use a precomputed lookup table? yes=1,no=0 (0) integer :: use_gas_abs = 1 ! include gaseous absorption? yes=1,no=0 (1) integer :: do_ray = 0 ! calculate/output Rayleigh refl=1, not=0 (0) - integer :: melt_lay = 0 ! melting layer model off=0, on=1 (0) real(r8) :: k2 = -1 ! |K|^2, -1=use frequency dependent default (-1) ! Variables for COSP input related to lidar simulator @@ -822,18 +820,6 @@ subroutine cospsimulator_intr_init() 'Asymmetry parameter (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('MODIS_ssa', (/'cosp_scol','trop_pref'/), 'I','1', & 'Single-scattering albedo (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot', (/'cosp_scol','trop_pref'/), 'I','1', & - 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot_ice', (/'cosp_scol','trop_pref'/), 'I','1', & - 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_betatot_liq', (/'cosp_scol','trop_pref'/), 'I','1', & - 'Backscatter coefficient (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot', (/'cosp_scol','trop_pref'/), 'I','1', & - 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot_ice', (/'cosp_scol','trop_pref'/), 'I','1', & - 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('CAL_tautot_liq', (/'cosp_scol','trop_pref'/), 'I','1', & - 'Vertically integrated ptical-depth (CALIPSO)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('CS_z_vol', (/'cosp_scol','trop_pref'/), 'I','1', & 'Effective reflectivity factor (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('CS_kr_vol', (/'cosp_scol','trop_pref'/), 'I','1', & @@ -854,12 +840,6 @@ subroutine cospsimulator_intr_init() call add_default('MODIS_fracliq', cosp_histfile_aux_num,' ') call add_default('MODIS_asym', cosp_histfile_aux_num,' ') call add_default('MODIS_ssa', cosp_histfile_aux_num,' ') - call add_default('CAL_betatot', cosp_histfile_aux_num,' ') - call add_default('CAL_betatot_ice', cosp_histfile_aux_num,' ') - call add_default('CAL_betatot_liq', cosp_histfile_aux_num,' ') - call add_default('CAL_tautot', cosp_histfile_aux_num,' ') - call add_default('CAL_tautot_ice', cosp_histfile_aux_num,' ') - call add_default('CAL_tautot_liq', cosp_histfile_aux_num,' ') call add_default('CS_z_vol', cosp_histfile_aux_num,' ') call add_default('CS_kr_vol', cosp_histfile_aux_num,' ') call add_default('CS_g_vol', cosp_histfile_aux_num,' ') @@ -904,7 +884,7 @@ subroutine setcosp2values() ! Local logical :: ldouble=.false. logical :: lsingle=.true. ! Default is to use single moment - integer :: i,k + integer :: k prsmid_cosp = pres_binCenters prslim_cosp = pres_binEdges @@ -944,8 +924,8 @@ subroutine setcosp2values() isccp_topheight, isccp_topheight_direction, surface_radar, rcfg_cloudsat, & use_vgrid, csat_vgrid, Nlr, nlay, cloudsat_micro_scheme) - if (use_vgrid) then !! using fixed vertical grid - if (csat_vgrid) then + if (use_vgrid) then !! using fixed vertical grid + if (csat_vgrid) then nht_cosp = 40 else nht_cosp = Nlr @@ -1056,7 +1036,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & use cam_history_support, only: max_fieldname_len #ifdef USE_COSP - use mod_cosp_config, only: R_UNDEF,parasol_nrefl, Nlvgrid, vgrid_zl, vgrid_zu + use mod_cosp_config, only: R_UNDEF,parasol_nrefl, Nlvgrid use mod_cosp, only: cosp_simulator use mod_quickbeam_optics, only: size_distribution #endif @@ -1303,9 +1283,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & real(r8) :: clrlmodis_cam(pcols,ntau_cosp*numMODISReffLiqBins) real(r8) :: clrlmodis(pcols,ntau_cosp,numMODISReffLiqBins) real(r8), dimension(pcols,nlay*nscol_cosp) :: & - tau067_out, emis11_out, fracliq_out, asym34_out, ssa34_out, & - cal_betatot,cal_betatot_ice, cal_betatot_liq, cal_tautot, cal_tautot_ice, & - cal_tautot_liq, cs_gvol_out, cs_krvol_out, cs_zvol_out + tau067_out, emis11_out, fracliq_out, asym34_out, ssa34_out type(interp_type) :: interp_wgts integer, parameter :: extrap_method = 1 ! sets extrapolation method to boundary value (1) @@ -1694,7 +1672,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! Construct COSP output derived type. ! ###################################################################################### call t_startf("construct_cosp_outputs") - call construct_cosp_outputs(ncol, nscol_cosp, nlay, Nlvgrid, 0, cospOUT) + call construct_cosp_outputs(ncol, nscol_cosp, nlay, Nlvgrid, cospOUT) call t_stopf("construct_cosp_outputs") ! ###################################################################################### @@ -2903,14 +2881,13 @@ end subroutine construct_cospstateIN ! ! This subroutine allocates output fields based on input logical flag switches. ! ###################################################################################### - subroutine construct_cosp_outputs(Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x) + subroutine construct_cosp_outputs(Npoints,Ncolumns,Nlevels,Nlvgrid,x) ! Inputs integer,intent(in) :: & Npoints, & ! Number of sampled points Ncolumns, & ! Number of subgrid columns Nlevels, & ! Number of model levels - Nlvgrid, & ! Number of levels in L3 stats computation - Nchan ! Number of RTTOV channels + Nlvgrid ! Number of levels in L3 stats computation ! Outputs type(cosp_outputs),intent(out) :: & From 9c605637049d096026de8fb91656e5da26f0b49a Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 15 Apr 2024 11:26:48 -0400 Subject: [PATCH 07/17] fix interface height and pressure inputs --- src/physics/cam/cospsimulator_intr.F90 | 43 +++++++++++++------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index b15266dc16..21538db980 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -1088,7 +1088,8 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! cosp convective value includes both deep and shallow convection real(r8), allocatable :: & zmid(:,:), & ! layer midpoint height asl (m) - zbot(:,:), & ! bottom interface height asl (m) + zint(:,:), & ! layer interface height asl (m) + surf_hgt(:), & ! surface height (m) landmask(:), & ! landmask (0 or 1) mr_ccliq(:,:), & ! mixing_ratio_convective_cloud_liquid (kg/kg) mr_ccice(:,:), & ! mixing_ratio_convective_cloud_ice (kg/kg) @@ -1519,7 +1520,8 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & allocate( & zmid(ncol,nlay), & - zbot(ncol,nlay), & + zint(ncol,nlayp), & + surf_hgt(ncol), & landmask(ncol), & mr_ccliq(ncol,nlay), & mr_ccice(ncol,nlay), & @@ -1543,12 +1545,13 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! add surface height (surface geopotential/gravity) to convert CAM heights based on ! geopotential above surface into height above sea level + surf_hgt = state%phis(:ncol)/gravit do k = 1, nlay - zmid(:,k) = state%zm(:ncol,ktop+k-1) + state%phis(:ncol)/gravit - ! bottom interface of each layer - zbot(:,k) = state%zi(:ncol,ktop+k) + state%phis(:ncol)/gravit + zmid(:,k) = state%zm(:ncol,ktop+k-1) + surf_hgt + zint(:,k) = state%zi(:ncol,ktop+k-1) + surf_hgt end do - + zint(:,nlayp) = surf_hgt + landmask = 0._r8 do i = 1, ncol if (cam_in%landfrac(i) > 0.01_r8) landmask(i)= 1 @@ -1684,21 +1687,19 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & call construct_cospstateIN(ncol, nlay, 0, cospstateIN) ! convert to degrees. Lat in range [-90,..,90], Lon in range [0,..,360] - cospstateIN%lat = state%lat(:ncol)*180._r8/pi - cospstateIN%lon = state%lon(:ncol)*180._r8/pi - cospstateIN%at = state%t(:ncol,ktop:pver) - cospstateIN%qv = q(:ncol,ktop:pver) - cospstateIN%o3 = o3(:ncol,ktop:pver) - cospstateIN%sunlit = cam_sunlit(:ncol) - cospstateIN%skt = cam_in%ts(:ncol) - cospstateIN%land = landmask - cospstateIN%pfull = state%pmid(:ncol,ktop:pver) - cospstateIN%phalf(:,1) = 0._r8 - cospstateIN%phalf(:,2:nlay+1) = state%pint(1:ncol,ktop+1:pverp) - cospstateIN%hgt_matrix = zmid - cospstateIN%hgt_matrix_half(:ncol,nlay+1) = 0._r8 - cospstateIN%hgt_matrix_half(:ncol,:nlay) = zbot - cospstateIN%surfelev = zbot(:ncol,nlay) + cospstateIN%lat = state%lat(:ncol)*180._r8/pi + cospstateIN%lon = state%lon(:ncol)*180._r8/pi + cospstateIN%at = state%t(:ncol,ktop:pver) + cospstateIN%qv = q(:ncol,ktop:pver) + cospstateIN%o3 = o3(:ncol,ktop:pver) + cospstateIN%sunlit = cam_sunlit(:ncol) + cospstateIN%skt = cam_in%ts(:ncol) + cospstateIN%land = landmask + cospstateIN%pfull = state%pmid(:ncol,ktop:pver) + cospstateIN%phalf = state%pint(:ncol,ktop:pverp) + cospstateIN%hgt_matrix = zmid + cospstateIN%hgt_matrix_half = zint + cospstateIN%surfelev = surf_hgt call t_stopf("construct_cospstateIN") ! Optical inputs From 66534c905bc670137da1a8a49c61f34e3972720f Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 15 Apr 2024 18:02:10 -0400 Subject: [PATCH 08/17] add ChangeLog --- doc/ChangeLog | 83 ++++++++++++++++++++++++++ src/physics/cam/cospsimulator_intr.F90 | 9 --- 2 files changed, 83 insertions(+), 9 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 4165695363..4f517b4af7 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,88 @@ =============================================================== +Tag name: +Originator(s): eaton +Date: +One-line Summary: Add vertical limit to COSP interface. +Github PR URL: + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +The COSP simulator was not working with "FMT" compsets. This compset has a +model top of about 1 Pa which is above where the cloud parameterizations +operate. The COSP interface routine was modified so that COSP operates on +the same vertical domain as the cloud parameterizations which is set the +the namelist variable trop_cloud_top_press (1 mb by default). Changing to +a dynamically determined top required reordering of calls to COSP interface +routines. In addition a lot of code cleanup was done, and a bug fix was +made for the layer interface values of height and pressure passed from CAM +to COSP. + +. resolves #967- COSP prevents running "FMT" compsets. + +Describe any changes made to build system: none + +Describe any changes made to the namelist: none + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: not measured, but COSP +should be less expensive in models with tops above 1 mb. + +Code reviewed by: + +List all files eliminated: none + +List all files added and what they do: none + +List all existing files that have been modified, and describe the changes: + +src/control/cam_history_support.F90 +. fix log output format + +src/physics/cam/cospsimulator_intr.F90 +. set top of data operated on by COSP using trop_cloud_top_lev +. cospsimulator_intr_register + - routine removed. Not needed since no constituents or pbuf fields to + register. Contents moved to cospsimulator_intr_init. +. cospsimulator_intr_readnl + - move the call to setcosp2values to cospsimulator_intr_init. +. remove outdated and/or unhelpful comments +. remove unused variables +. remove added history fields with no corresponding outfld calls +. remove array section notation from places where the whole array is used + +src/physics/cam/physpkg.F90 +src/physics/cam_dev/physpkg.F90 +. remove call to cospsimulator_intr_register + +src/physics/cam/ref_pres.F90 +. add calls to create vertical coordinate variables for the domain bounded + by trop_cloud_lev_top. Some COSP history fields need this coordinate. + +src/utils/hycoef.F90 +. add comment and fix a comment + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + +izumi/nag/aux_cam: + +izumi/gnu/aux_cam: + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: BFB. Some COSP diagnostic fields have +answer changes due to a bug fix in data sent to COSP. + +=============================================================== +=============================================================== + Tag name: cam6_3_155 Originator(s): katec,vlarson,bstephens82,huebleruwm,zarzycki,JulioTBacmeister Date: April 11, 2024 diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 21538db980..20f57d12ba 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -1164,9 +1164,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! CAM pointers to get variables from radiation interface (get from rad_cnst_get_gas) real(r8), pointer, dimension(:,:) :: q ! specific humidity (kg/kg) real(r8), pointer, dimension(:,:) :: o3 ! Mass mixing ratio 03 - real(r8), pointer, dimension(:,:) :: co2 ! Mass mixing ratio C02 - real(r8), pointer, dimension(:,:) :: ch4 ! Mass mixing ratio CH4 - real(r8), pointer, dimension(:,:) :: n2o ! Mass mixing ratio N20 ! CAM pointers to get variables from the physics buffer real(r8), pointer, dimension(:,:) :: cld ! cloud fraction, tca - total_cloud_amount (0-1) @@ -1197,7 +1194,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! Multiple "mdims" are collapsed because CAM history buffers only support one mdim. ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nlay, ! ntau_cosp*nhtmisr_cosp - ! Always making mixed variables VERTICAL*OTHER, e.g., pressure*tau or ht*dbze real(r8) :: clisccp2(pcols,ntau_cosp,nprs_cosp) real(r8) :: cfad_dbze94(pcols,CLOUDSAT_DBZE_BINS,nht_cosp) real(r8) :: cfad_lidarsr532(pcols,nsr_cosp,nht_cosp) @@ -1457,8 +1453,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! state%lat ! lat (radians) ! state%lon ! lon (radians) ! state%t ! temperature (K) - ! state%u ! u_wind zonal wind (m/s) - ! state%v ! v_wind meridional wind (m/s) ! state%ps ! surface pressure (Pa) ! state%pint ! p - p_in_full_levels (Pa) ! state%pmid ! ph - p_in_half_levels (Pa) @@ -1477,9 +1471,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! radiative constituents (prognostic or data) call rad_cnst_get_gas(0,'H2O', state, pbuf, q) call rad_cnst_get_gas(0,'O3', state, pbuf, o3) - call rad_cnst_get_gas(0,'CH4', state, pbuf, ch4) - call rad_cnst_get_gas(0,'CO2', state, pbuf, co2) - call rad_cnst_get_gas(0,'N2O', state, pbuf, n2o) ! fields from physics buffer itim_old = pbuf_old_tim_idx() From 168c3026b62f7c05e0ed305b81718ff976e90fbc Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 17 Apr 2024 10:57:49 -0400 Subject: [PATCH 09/17] fix for restart with COSP --- doc/ChangeLog | 20 ++++++------- src/physics/cam/cospsimulator_intr.F90 | 39 ++++++++++++++++++-------- src/physics/cam/physpkg.F90 | 4 +++ src/physics/cam_dev/physpkg.F90 | 4 +++ 4 files changed, 43 insertions(+), 24 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 4f517b4af7..2f1c11e944 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -13,10 +13,10 @@ model top of about 1 Pa which is above where the cloud parameterizations operate. The COSP interface routine was modified so that COSP operates on the same vertical domain as the cloud parameterizations which is set the the namelist variable trop_cloud_top_press (1 mb by default). Changing to -a dynamically determined top required reordering of calls to COSP interface -routines. In addition a lot of code cleanup was done, and a bug fix was -made for the layer interface values of height and pressure passed from CAM -to COSP. +a dynamically determined top required moving the call to COSP's +initialization. In addition a lot of code cleanup was done, and a bug fix +was made for the layer interface values of height and pressure passed from +CAM to COSP. . resolves #967- COSP prevents running "FMT" compsets. @@ -43,19 +43,15 @@ src/control/cam_history_support.F90 src/physics/cam/cospsimulator_intr.F90 . set top of data operated on by COSP using trop_cloud_top_lev . cospsimulator_intr_register - - routine removed. Not needed since no constituents or pbuf fields to - register. Contents moved to cospsimulator_intr_init. + - move the setcosp2values call here. That routine contains the call to + COSP's initialization. . cospsimulator_intr_readnl - - move the call to setcosp2values to cospsimulator_intr_init. + - move the call to setcosp2values to cospsimulator_intr_register. . remove outdated and/or unhelpful comments . remove unused variables -. remove added history fields with no corresponding outfld calls +. remove added history fields that had no corresponding outfld calls . remove array section notation from places where the whole array is used -src/physics/cam/physpkg.F90 -src/physics/cam_dev/physpkg.F90 -. remove call to cospsimulator_intr_register - src/physics/cam/ref_pres.F90 . add calls to create vertical coordinate variables for the domain bounded by trop_cloud_lev_top. Some COSP history fields need this coordinate. diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 20f57d12ba..0f7f1ff649 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -48,6 +48,7 @@ module cospsimulator_intr ! Public functions/subroutines public :: & cospsimulator_intr_readnl, & + cospsimulator_intr_register,& cospsimulator_intr_init, & cospsimulator_intr_run @@ -262,8 +263,6 @@ module cospsimulator_intr ! ###################################################################################### ! SUBROUTINE cospsimulator_intr_readnl - ! - ! Read namelist variables and run setcospvalues subroutine. ! ###################################################################################### subroutine cospsimulator_intr_readnl(nlfile) use namelist_utils, only: find_group_name @@ -431,19 +430,15 @@ subroutine cospsimulator_intr_readnl(nlfile) end subroutine cospsimulator_intr_readnl ! ###################################################################################### - ! SUBROUTINE cospsimulator_intr_init + ! SUBROUTINE cospsimulator_intr_register ! ###################################################################################### - subroutine cospsimulator_intr_init() + subroutine cospsimulator_intr_register() -#ifdef USE_COSP + ! The coordinate variables used for COSP output are defined here. This + ! needs to be done before the call to read_restart_history in order for + ! restarts to work. - use cam_history, only: addfld, add_default, horiz_only use cam_history_support, only: add_hist_coord - use physics_buffer, only: pbuf_get_index - - use mod_cosp_config, only : R_UNDEF - - integer :: i, ierr !--------------------------------------------------------------------------- ! Set number of levels used by COSP to the number of levels used by @@ -451,9 +446,10 @@ subroutine cospsimulator_intr_init() nlay = pver - ktop + 1 nlayp = nlay + 1 - ! COSP initialization + ! Set COSP coordinate arrays call setcosp2values() +#ifdef USE_COSP ! Define coordinate variables for COSP outputs. if (lisccp_sim .or. lmodis_sim) then call add_hist_coord('cosp_prs', nprs_cosp, 'COSP Mean ISCCP pressure', & @@ -513,6 +509,25 @@ subroutine cospsimulator_intr_init() bounds_name='cosp_reffliq_bnds',bounds=reffLIQ_binEdges_cosp) end if +#endif + end subroutine cospsimulator_intr_register + + ! ###################################################################################### + ! SUBROUTINE cospsimulator_intr_init + ! ###################################################################################### + subroutine cospsimulator_intr_init() + +#ifdef USE_COSP + + use cam_history, only: addfld, add_default, horiz_only + use physics_buffer, only: pbuf_get_index + + integer :: i, ierr + !--------------------------------------------------------------------------- + + ! The COSP init method was run from cospsimulator_intr_register in order to add + ! the history coordinate variables earlier as needed for the restart time sequencing. + ! ISCCP OUTPUTS if (lisccp_sim) then call addfld('FISCCP1_COSP', (/'cosp_tau','cosp_prs'/), 'A', 'percent', & diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index ba9fc57fdf..a439f84423 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -150,6 +150,7 @@ subroutine phys_register use aircraft_emit, only: aircraft_emit_register use cam_diagnostics, only: diag_register use cloud_diagnostics, only: cloud_diagnostics_register + use cospsimulator_intr, only: cospsimulator_intr_register use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not use radheat, only: radheat_register use subcol, only: subcol_register @@ -325,6 +326,9 @@ subroutine phys_register call cloud_diagnostics_register call radheat_register + ! COSP + call cospsimulator_intr_register + ! vertical diffusion call vd_register() else diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index c5fb88c754..46805c150e 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -143,6 +143,7 @@ subroutine phys_register use aircraft_emit, only: aircraft_emit_register use cam_diagnostics, only: diag_register use cloud_diagnostics, only: cloud_diagnostics_register + use cospsimulator_intr, only: cospsimulator_intr_register use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not use radheat, only: radheat_register use subcol, only: subcol_register @@ -301,6 +302,9 @@ subroutine phys_register call cloud_diagnostics_register call radheat_register + ! COSP + call cospsimulator_intr_register + ! vertical diffusion call vd_register() else From e41b16771b8a64d63324b10a0cd621361b63d3ac Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 17 Apr 2024 12:08:57 -0400 Subject: [PATCH 10/17] remove old topo file generation tools --- doc/ChangeLog | 11 +- tools/definehires/Makefile | 127 - tools/definehires/README | 114 - tools/definehires/gtopo30_to_10min.F90 | 721 ----- tools/definehires/shr_kind_mod.F90 | 20 - tools/definesurf/Makefile | 144 - tools/definesurf/README | 156 - tools/definesurf/ao.f90 | 141 - tools/definesurf/ao_i.f90 | 178 -- tools/definesurf/area_ave.f90 | 59 - tools/definesurf/binf2c.f90 | 218 -- tools/definesurf/cell_area.f90 | 51 - tools/definesurf/chkdims.f90 | 52 - tools/definesurf/endrun.f90 | 7 - tools/definesurf/fmain.f90 | 458 --- tools/definesurf/handle_error.f90 | 11 - tools/definesurf/inimland.f90 | 205 -- tools/definesurf/interplandm.f90 | 92 - tools/definesurf/lininterp.f90 | 174 -- tools/definesurf/map2f.f90 | 1039 ------- tools/definesurf/map_i.f90 | 136 - tools/definesurf/max_ovr.f90 | 93 - tools/definesurf/sghphis.f90 | 340 --- tools/definesurf/shr_kind_mod.f90 | 20 - tools/definesurf/sm121.f90 | 86 - tools/definesurf/terrain_filter.f90 | 320 -- tools/definesurf/varf2c.f90 | 219 -- tools/definesurf/wrap_nf.f90 | 146 - tools/topo_tool/bin_to_cube/Makefile | 82 - tools/topo_tool/bin_to_cube/README | 23 - tools/topo_tool/bin_to_cube/bin_to_cube.F90 | 931 ------ tools/topo_tool/bin_to_cube/shr_kind_mod.F90 | 20 - tools/topo_tool/cube_to_target/Makefile | 69 - tools/topo_tool/cube_to_target/README | 20 - .../cube_to_target/cube_to_target.F90 | 2008 ------------- .../topo_tool/cube_to_target/reconstruct.F90 | 2675 ----------------- tools/topo_tool/cube_to_target/remap.F90 | 1561 ---------- .../topo_tool/cube_to_target/shr_kind_mod.F90 | 20 - tools/topo_tool/gen_netCDF_from_USGS/Makefile | 80 - tools/topo_tool/gen_netCDF_from_USGS/README | 14 - .../create_netCDF_from_USGS.F90 | 830 ----- .../gen_netCDF_from_USGS/shr_kind_mod.F90 | 20 - 42 files changed, 10 insertions(+), 13681 deletions(-) delete mode 100644 tools/definehires/Makefile delete mode 100644 tools/definehires/README delete mode 100644 tools/definehires/gtopo30_to_10min.F90 delete mode 100644 tools/definehires/shr_kind_mod.F90 delete mode 100644 tools/definesurf/Makefile delete mode 100644 tools/definesurf/README delete mode 100644 tools/definesurf/ao.f90 delete mode 100644 tools/definesurf/ao_i.f90 delete mode 100644 tools/definesurf/area_ave.f90 delete mode 100644 tools/definesurf/binf2c.f90 delete mode 100644 tools/definesurf/cell_area.f90 delete mode 100644 tools/definesurf/chkdims.f90 delete mode 100644 tools/definesurf/endrun.f90 delete mode 100644 tools/definesurf/fmain.f90 delete mode 100644 tools/definesurf/handle_error.f90 delete mode 100644 tools/definesurf/inimland.f90 delete mode 100644 tools/definesurf/interplandm.f90 delete mode 100644 tools/definesurf/lininterp.f90 delete mode 100644 tools/definesurf/map2f.f90 delete mode 100644 tools/definesurf/map_i.f90 delete mode 100644 tools/definesurf/max_ovr.f90 delete mode 100644 tools/definesurf/sghphis.f90 delete mode 100644 tools/definesurf/shr_kind_mod.f90 delete mode 100644 tools/definesurf/sm121.f90 delete mode 100644 tools/definesurf/terrain_filter.f90 delete mode 100644 tools/definesurf/varf2c.f90 delete mode 100644 tools/definesurf/wrap_nf.f90 delete mode 100644 tools/topo_tool/bin_to_cube/Makefile delete mode 100644 tools/topo_tool/bin_to_cube/README delete mode 100644 tools/topo_tool/bin_to_cube/bin_to_cube.F90 delete mode 100644 tools/topo_tool/bin_to_cube/shr_kind_mod.F90 delete mode 100644 tools/topo_tool/cube_to_target/Makefile delete mode 100644 tools/topo_tool/cube_to_target/README delete mode 100644 tools/topo_tool/cube_to_target/cube_to_target.F90 delete mode 100644 tools/topo_tool/cube_to_target/reconstruct.F90 delete mode 100644 tools/topo_tool/cube_to_target/remap.F90 delete mode 100644 tools/topo_tool/cube_to_target/shr_kind_mod.F90 delete mode 100644 tools/topo_tool/gen_netCDF_from_USGS/Makefile delete mode 100644 tools/topo_tool/gen_netCDF_from_USGS/README delete mode 100644 tools/topo_tool/gen_netCDF_from_USGS/create_netCDF_from_USGS.F90 delete mode 100644 tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90 diff --git a/doc/ChangeLog b/doc/ChangeLog index 2f1c11e944..0314381291 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -20,6 +20,10 @@ CAM to COSP. . resolves #967- COSP prevents running "FMT" compsets. +Removed old tools for topo file generation. + +. resolves #1005 - Remove old topo generation software from CAM + Describe any changes made to build system: none Describe any changes made to the namelist: none @@ -31,7 +35,12 @@ should be less expensive in models with tops above 1 mb. Code reviewed by: -List all files eliminated: none +List all files eliminated: +tools/definehires/* +tools/definesurf/* +tools/topo_tool/* +. these tools for topo file generation have been replaced by + https://github.com/NCAR/Topo List all files added and what they do: none diff --git a/tools/definehires/Makefile b/tools/definehires/Makefile deleted file mode 100644 index ef34446982..0000000000 --- a/tools/definehires/Makefile +++ /dev/null @@ -1,127 +0,0 @@ -# Makefile to build definesurf on various platforms -# Note: If netcdf library is not built in the standard location, you must set the environment -# variables INC_NETCDF and LIB_NETCDF - -EXEDIR = . -EXENAME = definehires -RM = rm - -.SUFFIXES: -.SUFFIXES: .F90 .o - -# Check for the NetCDF library and include directories -ifeq ($(LIB_NETCDF),$(null)) -LIB_NETCDF := /usr/local/lib -endif - -ifeq ($(INC_NETCDF),$(null)) -INC_NETCDF := /usr/local/include -endif - -# Determine platform -UNAMES := $(shell uname -s) -UNAMEM := $(findstring CRAY,$(shell uname -m)) - -# Architecture-specific flags and rules -# -#------------------------------------------------------------------------ -# Cray -#------------------------------------------------------------------------ - -ifeq ($(UNAMEM),CRAY) -FC = f90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.F90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# SGI -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),IRIX64) -FC = f90 -FFLAGS = -c -I$(INC_NETCDF) -64 -mips4 -bytereclen -s -r8 -LDFLAGS = -64 -L/usr/local/lib64/r4i4 -L$(LIB_NETCDF) -lnetcdf -.F90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# SUN -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),SunOS) -FC = f90 -FFLAGS = -c -stackvar -f -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.F90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# AIX -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),AIX) -FC = xlf90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.F90.o: - $(FC) $(FFLAGS) -qsuffix=f=F90 $< -endif - -#------------------------------------------------------------------------ -# OSF1 -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),OSF1) -FC = f90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.F90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# Linux -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),Linux) -ifeq ($(USER_FC),$(null)) -FC := pgf90 -FFLAGS = -c -I$(INC_NETCDF) -fast -r8 -byteswapio -else -FC := $(USER_FC) -endif -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf - -ifeq ($(FC),lf95) - FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF) - ifeq ($(DEBUG),TRUE) - #TBH: this works FFLAGS += -g --chk --pca - #TBH: this FAILS FFLAGS += -g --chk a,e,s,u,x --pca - FFLAGS += -g --chk a,e,s,u --pca - else - FFLAGS += -O - endif -endif - -.F90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# Default rules and macros -#------------------------------------------------------------------------ - -OBJS := gtopo30_to_10min.o shr_kind_mod.o - -$(EXEDIR)/$(EXENAME): $(OBJS) - $(FC) -o $@ $(OBJS) $(LDFLAGS) - -clean: - $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME) - -gtopo30_to_10min.o: shr_kind_mod.o diff --git a/tools/definehires/README b/tools/definehires/README deleted file mode 100644 index 5834c3961a..0000000000 --- a/tools/definehires/README +++ /dev/null @@ -1,114 +0,0 @@ -*** Lahey compiler note If you build definehires with lf95, you must -*** execute with the -T runtime option, to get the proper byte -*** ordering on input. Otherwise, you get nonsense. The GTOPO30 input -*** files are binary, with "bigendian" ordering. -*** definesurf -Wl,-T - -Running gnumake in this directory will create an executable named -"definehires". Its function is to produce a 10-minute topography -dataset from a USGS 30-second topographic dataset. The 30-second -dataset contains only a height field. The 10-minute dataset contains - height field, a binary land mask, and a fractional land mask. - -Ocean points are indicated in the 30-second dataset by a missing data -flag and are assumed to have elevation 0m. However, the Caspian Sea -is not flagged as ocean. The definehires program generates a Caspian -Sea based on elevation, and reports these points as ocean while -generating the 10-minute dataset. This is done through three calls to -the new routine expand_sea. - -The 30-second dataset needed by definehires can be obtained from the -following USGS web site: - -http://edcdaac.usgs.gov/gtopo30/gtopo30.asp - -For each tile in the dataset, both the *.DEM and *.HDR files must be -present in the directory from which definehires is run. On NCAR -machines, this may be accomplished by repeating the following snippet -from a user csh or tcsh shell. - ->> foreach temp ( /fs/cgd/csm/inputdata/atm/cam2/gtopo30data/* ) -foreach? ln -s $temp -foreach? end - -Once the appropriate data files are in place, simply type: -./definehires - -This will produce a new 10-minute high-resolution dataset named -topo_gtopo30_10min.nc - - - -------------------------------------- -Feb 01, 2005 -------------------------------------- - -------------------------------------- -*********** definehires ************* -------------------------------------- - -The GTOPO30 30" is converted to a 10' dataset using definehires - Originally by Jiundar Chern (jchern@dao.gsfc.nasa.gov), - updated by Jim McCaa (jmccaa@ucar.edu) - updated by B.A. Boville - -./definehires generates file "topo_gtopo30_10min.nc" containing 5 variables - lon dimension variable of longitudes - lat dimension variable of latitudes - variance variance of 30" height w.r.t. 10' grid - htopo average terrain height on 10' grid - landfract land fraction on 10' grid, - cells are either land or ocean on 30" grid - Caspian sea is identified as ocean, but has nonzero height - -The original GTOPO30 files contain only elevation, with a flag for -ocean points (NODATA=-9999). The Caspian Sea is not connected to the -oceans and is not at sea level. Definehires identifies the Caspian Sea -in the 30" data using an algorithm based on elevation. Therefore, -the land fraction reflects the presence of the Caspian and the -elevation is nonzero. - -method: - - Subroutine expand_sea is called 3 times, once for each GTOPO30 tile - which contains part of the Caspian. The arguments include the x,y - indices of a start point which is known to be in the Caspian. These - 3 points had to identified by hand. - - 1. the start point is flagged by - adding NODATA + NODATA to the original height - setting a flag true for the block of surrounding points: - (startx-1:startx+1,starty-1:starty+1) - - 2. find points with the same elevation as the start point and whose - flag is true. Flag them the same way as the start point. - - This provides an expanding mask of potential Caspian points, which - are flagged true, and an expanding region of actual Caspian points - which are flagged with the original elavation + NODATA + NODATA. - - Subroutine avg is called to compute the area weighted average and - land fraction of the 30" data with respect to the 10' grid. The - weighting accounts for the area change with latitude. Points with - elavation = NODATA are given elevation = 0 and land fraction = - 0. Caspian points (elevation < NODATA) are given their original - elevation (elevation - NODATA - NODATA) and land fraction = 0. - - The variance of the 30" height data with respect to the 10' average - is computed without area weighting. - -Note on method. The Caspian terrain height flag is exact because the -height is an integer. However, I would have preferred to - - Convert the height of ocean points from NODATA to ZERO and make a - land fraction array with 0. or 1.. This could be done with a - subroutine find_ocn. - - Then the Caspian points would retain their original elevations and - also get land fraction 0 in find_caspian (instead of - expand_sea). Still called for only the 3 tiles. - - Subroutine avg would not have to recognize anything special about - Caspian points. - - diff --git a/tools/definehires/gtopo30_to_10min.F90 b/tools/definehires/gtopo30_to_10min.F90 deleted file mode 100644 index 50ccae5c2e..0000000000 --- a/tools/definehires/gtopo30_to_10min.F90 +++ /dev/null @@ -1,721 +0,0 @@ -! -! DATE CODED: Oct 17, 2000 -! DESCRIPTION: This program reads USGS 30-sec terrain dataset in 33 tiles and converts -! them to 10-min resolution global dataset in one single NetCDF file. -! -! Author: Jiundar Chern (jchern@dao.gsfc.nasa.gov) -! -! ** Modified November, 2003 *** -! This code has been modified by Jim McCaa (jmccaa@ucar.edu) for use at NCAR. -! In particular: -! 1) Paths and compiler options have been changed. -! 2) The code now generates a Caspian Sea based on elevation, and reports these points -! as ocean. This is done through three calls to the new routine expand_sea. -! -! ** Modified February 4, 2005 B.A. Boville *** -! -! ROUTINES CALLED: -! netcdf routines -! -! COMPILING: -! -! NCAR SGI (chinookfe) f90 -I/usr/local/include -O -64 -mips4 -bytereclen -s -! -o gtopo30_to_10min gtopo30_to_10min.F90 -L/usr/local/lib64/r4i4 -lnetcdf -r8 - -! NASA DAO SGI: f90 -I/ford1/local/IRIX64/netcdf/include -O -64 -mips4 -bytereclen -s -! -o gtopo30_to_10min gtopo30_to_10min.F90 -L/ford1/local/IRIX64/netcdf/lib -lnetcdf -r8 - - program convterr - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This program converts USGS 30-sec terrain data set to 10-min resolution -! terrain data set. -! - implicit none -! - integer, parameter :: ntile = 33 ! number of tiles in USGS GTOPO30 dataset - integer, parameter :: im10 = 2160 ! total grids in x direction of 10-min global dataset - integer, parameter :: jm10 = 1080 ! total grids in y direction of 10-min global dataset - real(r8), parameter :: dx30s = 1.0/120.0 ! space interval for 30-sec data (in degree) - real(r8), parameter :: dx10m = 1.0/6.0 ! space interval for 10-min data (in degree) - - character (len=7) :: nmtile(ntile) ! name of each tile - integer :: ncols,nrows ! number of columns and rows for 30-sec tile - integer :: nodata ! integer for ocean point - integer :: ncol10,nrow10 ! number of columns and rows for 10-min tile - real(r8):: ulxmap ! longitude at the center of the upper-left corner cell in the 30-sec tile - real(r8):: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile - real(r8):: lon1_10m ! longitude at the center of grid (1,1) in the 10-min global data - real(r8):: lat1_10m ! latitude at the center of grid (1,1) in the 10-min global data - real(r8):: lonsw10 ! longitude at the center of southwest corner cell in the 10-min tile - real(r8):: latsw10 ! latitude at the center of southwest corner cell in the 10-min tile - integer :: i1,j1 ! the (i,j) point of the southwest corner of the 10-min tile in the global grid - real(r8), dimension(im10,jm10) :: terr ! global 10-min terrain data - real(r8), dimension(im10,jm10) :: variance ! global 10-min variance of elevation - real(r8), dimension(im10,jm10) :: land_fraction !global 10-min land fraction - - integer :: alloc_error,dealloc_error - integer :: i,j,n ! index - integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile - real(r8), allocatable, dimension(:,:) :: terr10m ! terrain data for 10-min tile - real(r8), allocatable, dimension(:,:) :: psea10m ! percentage of ocaen for 10-min tile - real(r8), allocatable, dimension(:,:) :: var10m ! variance of 30-sec elevations for 10-min tile -! - lat1_10m=-90.0 + 0.5 * dx10m - lon1_10m=0.5*dx10m -! -! Initialize each tile name -! - nmtile(1) = 'W180N90' - nmtile(2) = 'W140N90' - nmtile(3) = 'W100N90' - nmtile(4) = 'W060N90' - nmtile(5) = 'W020N90' - nmtile(6) = 'E020N90' - nmtile(7) = 'E060N90' - nmtile(8) = 'E100N90' - nmtile(9) = 'E140N90' - - nmtile(10) = 'W180N40' - nmtile(11) = 'W140N40' - nmtile(12) = 'W100N40' - nmtile(13) = 'W060N40' - nmtile(14) = 'W020N40' - nmtile(15) = 'E020N40' - nmtile(16) = 'E060N40' - nmtile(17) = 'E100N40' - nmtile(18) = 'E140N40' - - nmtile(19) = 'W180S10' - nmtile(20) = 'W140S10' - nmtile(21) = 'W100S10' - nmtile(22) = 'W060S10' - nmtile(23) = 'W020S10' - nmtile(24) = 'E020S10' - nmtile(25) = 'E060S10' - nmtile(26) = 'E100S10' - nmtile(27) = 'E140S10' - - nmtile(28) = 'W180S60' - nmtile(29) = 'W120S60' - nmtile(30) = 'W060S60' - nmtile(31) = 'W000S60' - nmtile(32) = 'E060S60' - nmtile(33) = 'E120S60' - - do j = 1, jm10 - do i = 1, im10 - terr(i,j) = -9999.0 - variance(i,j) = -9999.0 - land_fraction(i,j) = -9999.0 - end do - end do - - do n = 1,ntile -! -! Read header for each tile -! - call rdheader(nmtile(n),nrows,ncols,nodata,ulxmap,ulymap) - -! -! Allocate space for array iterr -! - allocate ( iterr(ncols,nrows),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for iterr' - stop - end if -! -! Read terr data for each tile -! - call rdterr(nmtile(n),nrows,ncols,iterr) -! -! Allocate space for arrays terr10m and psea10m -! - nrow10 =nrows*dx30s/dx10m - ncol10 =ncols*dx30s/dx10m - allocate ( terr10m(ncol10,nrow10),psea10m(ncol10,nrow10),var10m(ncol10,nrow10),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr10m, psea10m, and var10m' - stop - end if -! -! Expand Caspian Sea for tiles 6 and 15 -! - if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,3600,5300) - if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,4088,5874) - if(nmtile(n).eq.'E020N40')call expand_sea(ncols,nrows,iterr,nodata,3600,1) -! -! area average of 30-sec tile to 10-min tile -! - call avg(ncols,nrows,iterr,nodata,ulymap,dx30s,ncol10,nrow10,terr10m,psea10m,var10m) - -! -! Print some info on the fields - print *, "min and max elevations: ", minval(terr10m), maxval(terr10m) - print *, "min and max variacnes: ", minval(var10m) , maxval(var10m) - print *, "min and max land frac: ", minval(psea10m), maxval(psea10m) -! -! fit the 10-min tile into global 10-min dataset -! Note: the 30-sec and 10-min tiles are scaned from north to south, the global 10-min dataset are -! scaned from south to north (90S to 90N) and east to west (0E to -0.1666667W) -! - latsw10 = nint(ulymap + 0.5 * dx30s) - nrow10 * dx10m + 0.5 * dx10m - lonsw10 = nint(ulxmap - 0.5 * dx30s) + 0.5 * dx10m - if( lonsw10 < 0.0 ) lonsw10=360.0+lonsw10 - i1 = nint( (lonsw10 - lon1_10m) / dx10m )+1 - if( i1 <= 0 ) i1 = i1 + im10 - if( i1 > im10 ) i1 = i1 - im10 - j1 = nint( (latsw10 - lat1_10m) / dx10m )+1 - -! print*,'ulymap,ulxmap,latsw10,lonsw10 = ',ulymap,ulxmap,latsw10,lonsw10 -! print*,'i1,j1 = ', i1,j1 - - call fitin(ncol10,nrow10,terr10m,psea10m,var10m,i1,j1,im10,jm10,terr,variance,land_fraction) -! -! Deallocate working space for arrays iterr, terr10m and psea10m -! - deallocate ( iterr,terr10m,psea10m,var10m,stat=dealloc_error ) - if( dealloc_error /= 0 ) then - print*,'Unexpected deallocation error for arrays iterr,terr10m,psea10m,var10m' - stop - end if - - end do - -! -! Print some info on the fields - print *, "min and max elevations: ", minval(terr), maxval(terr) - print *, "min and max variances: ", minval(variance), maxval(variance) - print *, "min and max land frac: ", minval(land_fraction), maxval(land_fraction) -! -! Write 10-min terrain dataset, variance and land_fraction to NetCDF file -! - call wrtncdf(im10,jm10,terr,variance, land_fraction,dx10m) - - end program convterr - - subroutine rdheader(nmtile,nrows,ncols,nodata,ulxmap,ulymap) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine read the header of USGA Global30 sec TOPO data set. -! - implicit none -! -! Dummy arguments -! - character (len=7), intent(in) :: nmtile ! name of the tile - integer, intent(out) :: nrows ! number of rows - integer, intent(out) :: ncols ! number of column - integer, intent(out) :: nodata ! integer for ocean data point - real(r8), intent(out) :: ulxmap - real(r8), intent(out) :: ulymap -! -! Local variables -! - character (len=11) :: flheader ! file name of the header - character (len=13) :: chars ! dummy character - - flheader=nmtile//'.HDR' - - print*,'flheader = ', flheader -! -! Open GTOPO30 Header File -! - open(unit=10,file=flheader,status='old',form='formatted') -! -! Read GTOPO30 Header file -! - read (10, *) - read (10, *) - read (10, *) chars,nrows - print*,chars,' = ',nrows - read (10, *) chars,ncols - print*,chars,' = ',ncols - read (10, *) - read (10, *) - read (10, *) - read (10, *) - read (10, *) - read (10, *) chars,nodata - print*,chars,' = ',nodata - read (10, *) chars,ulxmap - print*,chars,' = ',ulxmap - read (10, *) chars,ulymap - print*,chars,' = ',ulymap - close(10) - - end subroutine rdheader - - subroutine rdterr(nmtile,nrows,ncols,iterr) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine read the USGS Global 30-sec terrain data for each tile. -! - implicit none -! -! Dummy arguments -! - character (len=7), intent(in) :: nmtile ! name of the tile - integer, intent(in) :: nrows ! number of rows - integer, intent(in) :: ncols ! number of column - integer*2, dimension(ncols,nrows), intent(out) :: iterr ! terrain data -! -! Local variables -! - character (len=11) :: flterr ! file name for each terr dataset - integer :: io_error ! I/O status - integer :: i,j ! Index - integer :: length ! record length - - flterr=nmtile//'.DEM' - -! print*,'flterr = ', flterr -! print*,'nrows,ncols = ',nrows,ncols -! -! Open GTOPO30 Terrain dataset File -! - - length = 2 * ncols * nrows - io_error=0 - open(unit=11,file=flterr,access='direct',recl=length,iostat=io_error) - if( io_error /= 0 ) then - print*,'Open file error in subroutine rdterr' - print*,'iostat = ', io_error - stop - end if -! -! Read GTOPO30 Terrain data file -! - read (11,rec=1,iostat=io_error) ((iterr(i,j),i=1,ncols),j=1,nrows) -! - if( io_error /= 0 ) then - print*,'Data file error in subroutine rdterr' - print*,'iostat = ', io_error - stop - end if -! -! Print some info on the fields - print *, "min and max elevations: ", minval(iterr), maxval(iterr) -! -! Correct missing data in source files -! -! Missing data near dateline - - if( nmtile == 'W180S60' ) then - do j = 1, nrows - iterr(1,j) = iterr(2,j) - end do - else if (nmtile == 'E120S60') then - do j = 1, nrows - iterr(ncols-1,j) = iterr(ncols-2,j) - iterr(ncols,j) = iterr(ncols-2,j) - end do - end if -! -! Missing data at the southermost row near South pole -! - if( nmtile == 'E060S60' .or. nmtile == 'E120S60' .or. nmtile == 'W000S60' .or. & - nmtile == 'W060S60' .or. nmtile == 'W120S60' .or. nmtile == 'W180S60' ) then - do i=1,ncols - iterr(i,nrows) = iterr(i,nrows-1) - end do - end if -! -! print*,'iterr(1,1),iterr(ncols,nrows) = ', & -! iterr(1,1),iterr(ncols,nrows) - - close (11) - end subroutine rdterr - - subroutine avg(ncols,nrows,iterr,nodata,ulymap,dx30s,ncol10,nrow10,terr10m,psea10m,var10m) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine reduces the resolution of the terrain data from 30-sec to 10-min and -! compute the percentage of ocean cover (psea10m) -! - implicit none -! -! Dummy arguments -! - integer, intent(in) :: ncols ! number of column for 30-sec tile - integer, intent(in) :: nrows ! number of rows for 30-sec tile - integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile - integer, intent(in) :: nodata ! integer for ocean data point - real(r8),intent(in) :: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile - real(r8),intent(in) :: dx30s ! spacing interval for 30-sec data (in degree) - integer, intent(in) :: nrow10 ! number of rows for 10-min tile - integer, intent(in) :: ncol10 ! number of columns for 10-min tile - real(r8), dimension(ncol10,nrow10), intent(out) :: terr10m ! terrain data for 10-min tile - real(r8), dimension(ncol10,nrow10), intent(out) :: psea10m ! percentage ocean coverage for 10-min tile - real(r8), dimension(ncol10,nrow10), intent(out) :: var10m ! variance of 30-sec elevations -! -! Local variables -! - real(r8) :: lats,latn ! latitudes (in rad) for ths south and north edges of each 30-sec cell - real(r8) :: wt ! area weighting of each 30-sec cell - real(r8) :: wt_tot ! total weighting of each 10-min cell - real(r8) :: sumterr ! summation of terrain height of each 10-min cell - real(r8) :: sumsea ! summation of sea coverage of each 10-min cell - real(r8) :: pi ! pi=3.1415 - real(r8) :: latul ! latitude of the upper-left coner of 30-sec tile - integer :: n1,itmp,i1,i2,j1,j2 ! temporary working spaces - integer :: i,j,ii,jj ! index - logical, dimension(ncols,nrows) :: oflag - - pi = 4.0 * atan(1.0) -! - n1 = ncols / ncol10 - print*,'ncols,ncol10,n1 = ',ncols,ncol10,n1 - - itmp = nint( ulymap + 0.5 * dx30s ) - latul = itmp - print*,'ulymap,latul = ', ulymap,latul - oflag = .false. - - do j = 1, nrow10 - j1 = (j-1) * n1 + 1 - j2 = j * n1 - do i = 1, ncol10 - i1 = (i-1) * n1 + 1 - i2 = i * n1 - wt_tot = 0.0 - sumterr = 0.0 - sumsea = 0.0 - - do jj = j1, j2 - latn = ( latul - (jj -1) * dx30s ) * pi / 180.0 - lats = ( latul - jj * dx30s ) * pi / 180.0 - wt = sin( latn ) - sin( lats ) - - do ii = i1, i2 - wt_tot=wt_tot+wt - if ( iterr(ii,jj) == nodata ) then - sumsea = sumsea + wt - oflag(ii,jj) = .true. - else - if ( iterr(ii,jj) .lt.nodata ) then - ! this can only happen in the expand_sea routine - sumsea = sumsea + wt - oflag(ii,jj) = .true. - iterr(ii,jj) = iterr(ii,jj) - nodata - nodata - endif - sumterr = sumterr + iterr(ii,jj) * wt - end if - end do - end do - - terr10m(i,j) = sumterr / wt_tot - psea10m(i,j) = sumsea / wt_tot - - end do - end do - - ! Now compute variance of 30-second points - - do j = 1, nrow10 - j1 = (j-1) * n1 + 1 - j2 = j * n1 - - do i = 1, ncol10 - i1 = (i-1) * n1 + 1 - i2 = i * n1 - - wt_tot = 0.0 - var10m(i,j) = 0.0 - wt = 1.0 - do jj = j1, j2 - do ii = i1, i2 - wt_tot = wt_tot + wt - if ( .not. oflag(ii,jj) ) then - var10m(i,j) = var10m(i,j) + wt * (iterr(ii,jj)-terr10m(i,j))**2 - end if - end do - end do - var10m(i,j) = var10m(i,j) / wt_tot - - end do - end do - - end subroutine avg - - subroutine expand_sea(ncols,nrows,iterr,nodata,startx,starty) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine reduces the resolution of the terrain data from 30-sec to 10-min and -! compute the percentage of ocean cover (psea10m) -! - implicit none -! -! Dummy arguments -! - integer, intent(in) :: ncols ! number of column for 30-sec tile - integer, intent(in) :: nrows ! number of rows for 30-sec tile - integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile - integer, intent(in) :: nodata ! integer for ocean data point - integer, intent(in) :: startx, starty ! where to begin the sea -! -! Local variables -! - real(r8):: maxh - integer :: i,j,per,ii,jj ! index - logical, dimension(0:ncols+1,0:nrows+1) :: flag ! terrain data for 30-sec tile - logical :: found - - flag = .false. - - maxh = iterr(startx,starty) - - iterr(startx,starty) = iterr(startx,starty) + nodata + nodata - flag(startx-1:startx+1,starty-1:starty+1) = .true. - - per = 0 - print *, 'expanding sea at ',maxh,' m ' - -2112 per = per + 1 - found = .false. - do j = starty - per, starty + per, per*2 - do i = startx - per, startx + per - if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then - if( iterr(i,j).eq.maxh .and. flag(i,j) ) then - iterr(i,j) = iterr(i,j) + nodata + nodata - flag(i-1:i+1,j-1:j+1) = .true. - found = .true. - endif - endif - end do - end do - - do i = startx - per, startx + per, per*2 - do j = starty - per + 1, starty + per - 1 - if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then - if( iterr(i,j).eq.maxh .and. flag(i,j) ) then - iterr(i,j) = iterr(i,j) + nodata + nodata - flag(i-1:i+1,j-1:j+1) = .true. - found = .true. - endif - endif - end do - end do - if (found)goto 2112 - print *, 'done with expand_sea' - return - - end subroutine expand_sea - - subroutine fitin(ncol10,nrow10,terr10m,psea10m,var10m,i1,j1,im10,jm10,terr,variance,land_fraction) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine put 10-min tile into the global dataset -! - implicit none -! -! Dummy arguments -! - integer, intent(in) :: ncol10 ! number of columns for 10-min tile - integer, intent(in) :: nrow10 ! number of rows for 10-min tile - real(r8), dimension(ncol10,nrow10), intent(in) :: terr10m ! terrain data for 10-min tile - real(r8), dimension(ncol10,nrow10), intent(in) :: psea10m ! percentage ocean coverage for 10-min tile - real(r8), dimension(ncol10,nrow10), intent(in) :: var10m ! variance of 30-sec elev for 10-min tile - integer, intent(in) :: i1,j1 ! the (i,j) point of the southwest corner of the 10-min tile - ! in the global grid - integer, intent(in) :: im10,jm10 ! the dimensions of the 10-min global dataset - real(r8),dimension(im10,jm10), intent(out) :: terr ! global 10-min terrain data - real(r8),dimension(im10,jm10), intent(out) :: variance ! global 10-min variance of elev - real(r8),dimension(im10,jm10), intent(out) :: land_fraction ! global 10-min land fraction -! -! Local variables -! - integer :: i,j,ii,jj ! index - - do j = 1, nrow10 - jj = j1 + (nrow10 - j) - do i = 1, ncol10 - ii = i1 + (i-1) - if( ii > im10 ) ii = ii - im10 - terr(ii,jj) = terr10m(i,j) - land_fraction(ii,jj) = 1.0 - psea10m(i,j) - variance(ii,jj) = var10m(i,j) - if( i == 1 .and. j == 1 ) & - print*,'i,j,ii,jj = ',i,j,ii,jj - if( i == ncol10 .and. j == nrow10 ) & - print*,'i,j,ii,jj = ',i,j,ii,jj - end do - end do - end subroutine fitin - - subroutine wrtncdf(im10,jm10,terr,variance,land_fraction,dx10m) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine save 10-min terrain data, variance, land fraction to NetCDF file -! - implicit none - -# include - -! -! Dummy arguments -! - integer, intent(in) :: im10,jm10 ! the dimensions of the 10-min global dataset - real(r8),dimension(im10,jm10), intent(in) :: terr ! global 10-min terrain data - real(r8),dimension(im10,jm10), intent(in) :: variance ! global 10-min variance data - real(r8),dimension(im10,jm10), intent(in) :: land_fraction !global 10-min land fraction - real(r8), intent(in) :: dx10m -! -! Local variables -! - real(r8),dimension(im10) :: lonar ! longitude array - real(r8),dimension(im10) :: latar ! latitude array - character (len=32) :: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: varianceid - integer :: htopoid - integer :: landfid - integer, dimension(2) :: variancedim,htopodim,landfdim - integer :: status ! return value for error control of netcdf routin - integer :: i,j - character (len=8) :: datestring - -! -! Fill lat and lon arrays -! - do i = 1,im10 - lonar(i)= dx10m * (i-0.5) - enddo - do j = 1,jm10 - latar(j)= -90.0 + dx10m * (j-0.5) - enddo - - fout='topo_gtopo30_10min.nc' -! -! Create NetCDF file for output -! - status = nf_create (fout, NF_WRITE, foutid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Create dimensions for output -! - status = nf_def_dim (foutid, 'lon', im10, lonid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'lat', jm10, latid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Create variable for output -! - variancedim(1)=lonid - variancedim(2)=latid - status = nf_def_var (foutid,'variance', NF_FLOAT, 2, variancedim, varianceid) - if (status .ne. NF_NOERR) call handle_err(status) - - htopodim(1)=lonid - htopodim(2)=latid - status = nf_def_var (foutid,'htopo', NF_FLOAT, 2, htopodim, htopoid) - if (status .ne. NF_NOERR) call handle_err(status) - - landfdim(1)=lonid - landfdim(2)=latid - status = nf_def_var (foutid,'landfract', NF_FLOAT, 2, landfdim, landfid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! Create attributes for output variables -! - status = nf_put_att_text (foutid,varianceid,'long_name', 29, 'variance of 30-sec elevations') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,varianceid,'units', 8, 'meter**2') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,htopoid,'long_name', 41, '10-min elevation from USGS 30-sec dataset') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,htopoid,'units', 5, 'meter') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,landfid,'long_name', 23, '10-minute land fraction') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,landfid,'units', 14, 'fraction (0-1)') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '10-minute USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! End define mode for output file -! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Write variable for output -! - status = nf_put_var_double (foutid, varianceid, variance) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_var_double (foutid, htopoid, terr) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_var_double (foutid, landfid, land_fraction) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_var_double (foutid, latvid, latar) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_var_double (foutid, lonvid, lonar) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! Close output file -! - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - - end subroutine wrtncdf -!************************************************************************ -!!handle_err -!************************************************************************ -! -!!ROUTINE: handle_err -!!DESCRIPTION: error handler -!-------------------------------------------------------------------------- - - subroutine handle_err(status) - - implicit none - -# include - - integer status - - if (status .ne. nf_noerr) then - print *, nf_strerror(status) - stop 'Stopped' - endif - - end subroutine handle_err - - diff --git a/tools/definehires/shr_kind_mod.F90 b/tools/definehires/shr_kind_mod.F90 deleted file mode 100644 index fc1ed8e94a..0000000000 --- a/tools/definehires/shr_kind_mod.F90 +++ /dev/null @@ -1,20 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - -END MODULE shr_kind_mod diff --git a/tools/definesurf/Makefile b/tools/definesurf/Makefile deleted file mode 100644 index dd13a5bdd4..0000000000 --- a/tools/definesurf/Makefile +++ /dev/null @@ -1,144 +0,0 @@ -# Makefile to build definesurf on various platforms -# Note: If netcdf library is not built in the standard location, you must set the environment -# variables INC_NETCDF and LIB_NETCDF - -EXEDIR = . -EXENAME = definesurf -RM = rm - -.SUFFIXES: -.SUFFIXES: .f90 .o - -# Check for the NetCDF library and include directories -ifeq ($(LIB_NETCDF),$(null)) -LIB_NETCDF := /usr/local/lib -endif - -ifeq ($(INC_NETCDF),$(null)) -INC_NETCDF := /usr/local/include -endif - -# Determine platform -UNAMES := $(shell uname -s) -UNAMEM := $(findstring CRAY,$(shell uname -m)) - -# Architecture-specific flags and rules -# -#------------------------------------------------------------------------ -# Cray -#------------------------------------------------------------------------ - -ifeq ($(UNAMEM),CRAY) -FC = f90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.f90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# SGI -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),IRIX64) -FC = f90 -FFLAGS = -64 -c -I$(INC_NETCDF) -LDFLAGS = -64 -L/usr/local/lib64/r4i4 -lnetcdf -.f90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# SUN -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),SunOS) -FC = f90 -FFLAGS = -c -stackvar -f -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.f90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# AIX -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),AIX) -FC = xlf90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.f90.o: - $(FC) $(FFLAGS) -qsuffix=f=f90 $< -endif - -#------------------------------------------------------------------------ -# OSF1 -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),OSF1) -FC = f90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.f90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# Linux -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),Linux) -ifeq ($(USER_FC),$(null)) -FC := pgf90 -FFLAGS = -c -I$(INC_NETCDF) -fast -else -FC := $(USER_FC) -endif -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf - -ifeq ($(FC),lf95) -FFLAGS = -c --trace --trap -I$(INC_NETCDF) -g -LDFLAGS += -g -endif - -.f90.o: - $(FC) $(FFLAGS) $< -endif - -#------------------------------------------------------------------------ -# Default rules and macros -#------------------------------------------------------------------------ - -OBJS := ao.o ao_i.o area_ave.o binf2c.o cell_area.o \ - chkdims.o endrun.o fmain.o handle_error.o inimland.o \ - lininterp.o map_i.o max_ovr.o shr_kind_mod.o sghphis.o sm121.o \ - terrain_filter.o varf2c.o wrap_nf.o interplandm.o map2f.o - -$(EXEDIR)/$(EXENAME): $(OBJS) - $(FC) -o $@ $(OBJS) $(LDFLAGS) - -clean: - $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME) - -ao.o: shr_kind_mod.o -ao_i.o: shr_kind_mod.o -area_ave.o: shr_kind_mod.o -binf2c.o: shr_kind_mod.o -cell_area.o: shr_kind_mod.o -chkdims.o: -endrun.o: -fmain.o: shr_kind_mod.o -handle_error.o: -inimland.o: shr_kind_mod.o -lininterp.o: shr_kind_mod.o -map_i.o: shr_kind_mod.o -max_ovr.o: shr_kind_mod.o -shr_kind_mod.o: -sghphis.o: shr_kind_mod.o -sm121.o: shr_kind_mod.o -terrain_filter.o: -map2f.o: -varf2c.o: shr_kind_mod.o -wrap_nf.o: -interplandm.o: diff --git a/tools/definesurf/README b/tools/definesurf/README deleted file mode 100644 index f0d9427e8e..0000000000 --- a/tools/definesurf/README +++ /dev/null @@ -1,156 +0,0 @@ -Running gnumake in this directory will create an executable named -"definesurf". Its function is to compute required CAM initial dataset -variables SGH, PHIS, and LANDFRAC from a high-resolution topography dataset, -and LANDM_COSLAT from a T42 "master", then add or replace the values on an -existing initial dataset. SGH is the standard deviation of PHIS used in the -gravity wave drag scheme. PHIS is the geopotential height. LANDFRAC is land -fraction. LANDM_COSLAT is a field derived from LANDFRAC which is required by -the prognostic cloud water parameterization. There is a cosine(latitude) -dependence built in to the function. - -The cam standard high resolution dataset is now based on the USGS -GTOPO30 digital elevation model at 30" resolution. It is converted to -10' resolution by definehires. - -The older high resolution topography dataset (10') used by definesurf -is named topo.nc and is included as part of the CAM distribution in -the datasets tar file. topo.nc was derived from the U.S. Navy Global -Elevation 10-MIN dataset DS754.0 Please refer to the following NCAR -website for more information: - -http://www.scd.ucar.edu/dss/catalogs/geo.html - -The algorithms within this code should be considered experimental. -For example, a 1-2-1 smoothing operator (sm121, called from subroutine -sghphis) is applied twice in succession to the topography variance -field regardless of horizontal resolution. Also, a spectral filter -will be applied to the PHIS field within the CAM at model startup -(except for the fv dycore) if PHIS was defined from the high -resolution topography dataset. The model determines this by checking -for the presence of netcdf attribute "from_hires" on variable PHIS. - -------------------------------------- -Feb 01, 2005 -------------------------------------- -------------------------------------- -*********** definesurf ************** -------------------------------------- - -A 10' data file is read in and averaged to the model grid by -definesurf. The present form of definesurf also takes a model initial -condition file as input and gets model grid description from it. The -terrain data mapped to the model grid is output on a new file. - -Command line flags are used for - -t name - (required) name of 10' data file - -g name - (required) name of cam initial condition file containing grid description - -l name - (required) name of land mask file on ?? grid - -r - (optional) do not extend Ross sea (default is extend) - -v - (optional) verbose (default is false) - -del2 - (optional) filter the elevations with a del2 filter (use for fv only) - -remap - (optional) filter the elevations with a remapping filter (use for fv only) - -sgh - (optional) filter the standard deviations with same filter as height - name - (required) name of i.c. file with existing terrain data, - must be final argument - -definesurf -t topo_gtopo30_10min.nc -g cami_*.nc -l landm_coslat.nc -remap oro_GTOPO30.nc -generates the file oro_GTOPO30.nc using the remapping filter. - -definesurf calls shgphis, which recognizes 2 input 10' data file formats - Old style, no 30" variance data on 10' grid, variance = -1 - land fraction called "ftopo" - New style, 30" variance data is present - land fraction called "landfract" - - Land fraction and 30" variance (if present) are averaged to the - model grid. - - if plon >= 128 then - Height is averaged to the model grid and the variance w.r.t to the - 10' data is computed. - if plon < 128 then - Height is averaged to a 3 degree grid and the variance w.r.t to the - 10' data is computed. The avg height and the variance of - the 3 degree data are then averaged to the model grid. - - 1-2-1 smoothers are applied twice to the model grid averaged values - of the two variance fields: 10' w.r.t. model grid; 30" w.r.t. 10' - (if 30" variance is present). - - The averaged and smoothed variances are converted to standard - deviations. - - The averaged height is converted to a geopotential (z*9.80616) - -Attributes are added to input file to describe what definesurf is doing. - -Land mask for clouds is interpolated to model grid. - -Extend land to -79 degrees for Ross ice shelf, unless -r flag was -set. - -Run terrain filter, if requested (-remap or -del2). Should only be -done for fv grids. For spectral grid, filtering is done in the model -based on the value of the attribute "from_hires". - Diffusive filter or remapping is appled to - surface geopotential - standard deviation of 10' data w.r.t. model grid - standard deviation of 30" data w.r.t. 10' grid (if present) - -**** It is not clear that the filter should be applied to the -**** standard deviations. - - The remapping filter removes structure near grid scale by using the - ppm mapping code to go to a half resolution grid and back to the - full resolution grid. Order (accuracy) parameters iord=7 and jord=3 - are used. A polar filter is also applied. - -------------------------------------------------------- -******* diffusive (-del2) terrain filter notes ******** -------------------------------------------------------- - -The del2 filter is a bit of a pain to figure out from the code (as is the -spectral one applied in the model for eul and sld dycores). It looks like - -(1) h(n+1) = h(n) + c*del2(h(n)), c=0.25 - -del2(h) = div(grad(h)) - -however, buried inside the del2 routine is a scaling by -CD = 0.25*DL*DP*coszc**2, - -coszc = cos(60*pi/180) [= 0.5] -DL = 2*pi/NLON is delta lambda -DP = pi / (NLAT-1) is delta phi -so -CD = 0.0625 * 2*pi/NLON * pi/(NLAT-1) = 0.4 / NLON / (NLAT-1) - -So the scaling factor reduces as the square of the resolution, just like -a del2 coefficient should, in order to maintain a constant damping rate -at the truncation limit. -CD = 3E-5, for 2x2.5 - -However, the number of iterations is NLON/12, so there is an additional -scaling upward of diffusion with resolution. - -going back to (1) -h(n+1) = h(n) + c*CD*del2(h(n)) -c*CD = 7.57E-6 for 2x2.5 -c*CD is just dt*k for a normal diffusion equation, where dt is the time -step and k is the diffusivity on the unit sphere. For a sphere with -radius a (=6.37E6), the diffusivity is K=k*a**2 . -Then dt*K = c*CD*a**2 = 3E8 and assuming dt=3600, K = 8.5E4 - -The del4 diffusivity in the spectral case is 5E15 at T63. The equivalent -del2 coefficient is K = 5E15 * 63*64/a**2 = 5E5 to damp wave 63 at the -same rate. - -So, we have K_fv ~ 8.5E4 and K_eul ~ 5E5. So the fv damping should -actually be less than the spectral/eulerian damping. - -Also, the damping is applied 25 times in the spectral case and NLON/12 -times for fv. NLON/12 =12 for 2x2.5, =24 for 1x1.25 and =48 for -0.5x0.625. - -The big difference is that the spectral/eulerian actually uses del4, -which confines the damping much closer to grid scale. diff --git a/tools/definesurf/ao.f90 b/tools/definesurf/ao.f90 deleted file mode 100644 index 33d7494215..0000000000 --- a/tools/definesurf/ao.f90 +++ /dev/null @@ -1,141 +0,0 @@ -subroutine ao (nlon_i , nlat_i , numlon_i, lon_i , lat_i , & - nlon_o , nlat_o , numlon_o, lon_o , lat_o , & - area_o , re , mx_ovr , n_ovr , i_ovr , & - j_ovr , w_ovr ) - - use shr_kind_mod, only: r8 => shr_kind_r8 - -! ----------------------------------------------------------------- - implicit none -! ------------------------ code history --------------------------- -! source file: ao.F -! purpose: weights and indices for area of overlap between -! input and output grids -! date last revised: March 1996 -! author: Gordon Bonan -! standardized: -! reviewed: -! ----------------------------------------------------------------- - -! ------------------- input variables ----------------------------- - integer nlon_i !maximum number of input longitude points - integer nlat_i !number of input latitude points - integer numlon_i(nlat_i) !number of input lon pts for each latitude - integer nlon_o !maximum number of output longitude points - integer nlat_o !number of output latitude points - integer numlon_o(nlat_o) !number of output lon pts for each latitude - integer mx_ovr !maximum number of overlapping input cells - - real(r8) lon_i(nlon_i+1,nlat_i) !input grid cell longitude, w. edge (deg) - real(r8) lon_o(nlon_o+1,nlat_o) !output grid cell longitude, w. edge (deg) - real(r8) lat_i(nlat_i+1) !input grid cell latitude, s. edge (deg) - real(r8) lat_o(nlat_o+1) !output grid cell latitude, s. edge (deg) - real(r8) area_o(nlon_o,nlat_o) !area of output grid cell - real(r8) re !radius of earth -! ----------------------------------------------------------------- - -! ------------------- input/output variables ---------------------- - integer n_ovr(nlon_o,nlat_o ) !number of overlapping input cells - integer i_ovr(nlon_o,nlat_o,mx_ovr) !lon index, overlapping input cell - integer j_ovr(nlon_o,nlat_o,mx_ovr) !lat index, overlapping input cell - - real(r8) w_ovr(nlon_o,nlat_o,mx_ovr) !overlap weights for input cells -! ----------------------------------------------------------------- - -! ------------------- local variables ----------------------------- - integer io,ii !output and input grids longitude loop index - integer jo,ji !output and input grids latitude loop index - - real(r8) lonw,lone,dx !west, east longitudes of overlap and difference - real(r8) lats,latn,dy !south, north latitudes of overlap and difference - real(r8) deg2rad !pi/180 - real(r8) a_ovr !area of overlap - real(r8) zero,one - parameter (zero=0.0) ! Needed as arg to "max" - parameter (one=1.) ! Needed as arg to "atan" -! ----------------------------------------------------------------- - - deg2rad = (4.*atan(one)) / 180. - -! ----------------------------------------------------------------- -! for each output grid cell: find overlapping input grid cell and area of -! input grid cell that overlaps with output grid cell. cells overlap if: -! -! southern edge of input grid < northern edge of output grid AND -! northern edge of input grid > southern edge of output grid -! -! western edge of input grid < eastern edge of output grid AND -! eastern edge of input grid > western edge of output grid -! -! lon_o(io,jo) lon_o(io+1,jo) -! -! | | -! --------------------- lat_o(jo+1) -! | | -! | | -! xxxxxxxxxxxxxxx lat_i(ji+1) | -! x | x | -! x input | x output | -! x cell | x cell | -! x ii,ji | x io,jo | -! x | x | -! x ----x---------------- lat_o(jo ) -! x x -! xxxxxxxxxxxxxxx lat_i(ji ) -! x x -! lon_i(ii,ji) lon_i(ii+1,ji) -! ----------------------------------------------------------------- - -! note that code does not vectorize but is only called during -! initialization. - - do jo = 1, nlat_o - do io = 1, numlon_o(jo) - -! loop through all input grid cells to find overlap with output grid. - - do ji = 1, nlat_i - if ( lat_i(ji ).lt.lat_o(jo+1) .and. & - lat_i(ji+1).gt.lat_o(jo ) ) then !lat ok - - do ii = 1, numlon_i(ji) - if ( lon_i(ii ,ji).lt.lon_o(io+1,jo) .and. & - lon_i(ii+1,ji).gt.lon_o(io ,jo) ) then !lon okay - -! increment number of overlapping cells. make sure 0 < n_ovr < mx_ovr - - n_ovr(io,jo) = n_ovr(io,jo) + 1 -! if (n_ovr(io,jo) .gt. mx_ovr) then -! write (6,*) 'AO error: n_ovr= ',n_ovr(io,jo), & -! ' exceeded mx_ovr = ',mx_ovr, & -! ' for output lon,lat = ',io,jo -! call endrun -! end if - -! determine area of overlap - - lone = min(lon_o(io+1,jo),lon_i(ii+1,ji))*deg2rad !e edge - lonw = max(lon_o(io ,jo),lon_i(ii ,ji))*deg2rad !w edge - dx = max(zero,(lone-lonw)) - latn = min(lat_o(jo+1),lat_i(ji+1))*deg2rad !n edge - lats = max(lat_o(jo ),lat_i(ji ))*deg2rad !s edge - dy = max(zero,(sin(latn)-sin(lats))) - a_ovr = dx*dy*re*re - -! determine indices and weights. re cancels in the division by area - - i_ovr(io,jo,n_ovr(io,jo)) = ii - j_ovr(io,jo,n_ovr(io,jo)) = ji - w_ovr(io,jo,n_ovr(io,jo)) = a_ovr/area_o(io,jo) - - end if - end do - - end if - end do - - end do - end do - - return -end subroutine ao diff --git a/tools/definesurf/ao_i.f90 b/tools/definesurf/ao_i.f90 deleted file mode 100644 index 87b96eb815..0000000000 --- a/tools/definesurf/ao_i.f90 +++ /dev/null @@ -1,178 +0,0 @@ -subroutine ao_i(nlon_i , nlat_i , numlon_i, lon_i , lat_i , & - nlon_o , nlat_o , numlon_o, lon_o , lat_o , & - mx_ovr , i_ovr , j_ovr , w_ovr , re , & - area_o , relerr ) - - use shr_kind_mod, only: r8 => shr_kind_r8 - -! ----------------------------------------------------------------- - implicit none -! ------------------------ code history --------------------------- -! source file: ao_i.F -! purpose: area averaging initialization: indices and weights -! date last revised: November 1996 -! author: Gordon Bonan -! standardized: -! reviewed: -! ----------------------------------------------------------------- - -! ------------------------ notes ---------------------------------- -! get indices and weights for area-averaging between input and output grids - -! o input grid does not have to be finer resolution than output grid - -! o both grids must be oriented south to north, i.e., cell(lat+1) -! must be north of cell(lat). the southern edge of the first row -! must be -90 (south pole) and the northern edge of the last row -! must be +90 (north pole) - -! o both grids must be oriented eastwards, i.e., cell(lon+1) must be -! east of cell(lon). but the two grids do not have to start at the -! same longitude, i.e., one grid can start at dateline and go east; -! the other grid can start at greenwich and go east. longitudes for -! the western edge of the cells must increase continuously and span -! 360 degrees. examples -! dateline : -180 to 180 (- longitudes west of greenwich) -! greenwich : 0 to 360 -! greenwich (centered): -dx/2 to -dx/2 + 360 (- longitudes west of greenwich) - -! for each output grid cell -! o number of input grid cells that overlap with output grid cell (n_ovr) -! o longitude index (1 <= i_ovr <= nlon_i) of the overlapping input grid cell -! o latitude index (1 <= j_ovr <= nlat_i) of the overlapping input grid cell - -! for field values fld_i on an input grid with dimensions nlon_i and nlat_i -! field values fld_o on an output grid with dimensions nlon_o and nlat_o are -! fld_o(io,jo) = -! fld_i(i_ovr(io,jo, 1),j_ovr(io,jo, 1)) * w_ovr(io,jo, 1) + -! ... + ... + -! fld_i(i_ovr(io,jo,mx_ovr),j_ovr(io,jo,mx_ovr)) * w_ovr(io,jo,mx_ovr) - -! error check: overlap weights of input cells sum to 1 for each output cell -! ----------------------------------------------------------------- - -! ------------------- input variables ----------------------------- - integer nlon_i !input grid max number of input longitude points - integer nlat_i !input grid number of input latitude points - integer numlon_i(nlat_i) !input grid number of lon points for each lat - integer nlon_o !output grid max number of output lon points - integer nlat_o !output grid number of output latitude points - integer numlon_o(nlat_o) !output grid number of lon points for each lat - integer mx_ovr !max num of input cells that overlap output cell - - real(r8) lon_i(nlon_i+1,nlat_i) !input grid cell lon, western edge (degrees) - real(r8) lon_o(nlon_o+1,nlat_o) !output grid cell lon, western edge (degrees) - real(r8) lat_i(nlat_i+1) !input grid cell lat, southern edge (degrees) - real(r8) lat_o(nlat_o+1) !output grid cell lat, southern edge (degrees) - real(r8) area_o(nlon_o,nlat_o) !cell area on output grid - real(r8) re !radius of earth - real(r8) relerr !max error: sum overlap weights ne 1 -! ----------------------------------------------------------------- - -! ------------------- output variables ---------------------------- - integer i_ovr(nlon_o,nlat_o,mx_ovr) !lon index, overlapping input cell - integer j_ovr(nlon_o,nlat_o,mx_ovr) !lat index, overlapping input cell - real(r8) w_ovr(nlon_o,nlat_o,mx_ovr) !overlap weights for input cells -! ----------------------------------------------------------------- - -! ------------------- local variables ----------------------------- - integer io,ii !input and output grids longitude loop index - integer jo,ji !input and output grids latitude loop index - integer n !overlapping cell index - - real(r8) offset !used to shift x-grid 360 degrees - real(r8) f_ovr !sum of overlap weights for cells on output grid -! -! Dynamic -! - integer n_ovr(nlon_o,nlat_o) !number of overlapping input cells - -! ----------------------------------------------------------------- -! initialize overlap weights on output grid to zero for maximum -! number of overlapping points. set lat and lon indices of overlapping -! input cells to dummy values. set number of overlapping cells to zero -! ----------------------------------------------------------------- - - do n = 1, mx_ovr - do jo = 1, nlat_o - do io = 1, numlon_o(jo) - i_ovr(io,jo,n) = 1 - j_ovr(io,jo,n) = 1 - w_ovr(io,jo,n) = 0. - end do - end do - end do - - do jo = 1, nlat_o - do io = 1, numlon_o(jo) - n_ovr(io,jo) = 0 - end do - end do - -! ----------------------------------------------------------------- -! first pass to find cells that overlap, area of overlap, and weights -! ----------------------------------------------------------------- - - call ao (nlon_i , nlat_i , numlon_i, lon_i , lat_i , & - nlon_o , nlat_o , numlon_o, lon_o , lat_o , & - area_o , re , mx_ovr , n_ovr , i_ovr , & - j_ovr , w_ovr ) - -! ----------------------------------------------------------------- -! second pass to find cells that overlap, area of overlap, and weights -! ----------------------------------------------------------------- - -! shift x-grid to locate periodic grid intersections -! the following assumes that all lon_i(1,:) have the same value -! independent of latitude and that the same holds for lon_o(1,:) - - if (lon_i(1,1) .lt. lon_o(1,1)) then - offset = 360.0 - else - offset = -360.0 - end if - - do ji = 1,nlat_i - do ii = 1, numlon_i(ji) + 1 - lon_i(ii,ji) = lon_i(ii,ji) + offset - end do - end do - -! find overlap - - call ao (nlon_i , nlat_i , numlon_i , lon_i , lat_i , & - nlon_o , nlat_o , numlon_o , lon_o , lat_o , & - area_o , re , mx_ovr , n_ovr , i_ovr , & - j_ovr , w_ovr ) - -! restore x-grid (un-shift x-grid) - - do ji = 1,nlat_i - do ii = 1, numlon_i(ji) + 1 - lon_i(ii,ji) = lon_i(ii,ji) - offset - end do - end do - -! ----------------------------------------------------------------- -! error check: overlap weights for input grid cells must sum to 1 -! ----------------------------------------------------------------- - - do jo = 1, nlat_o - do io = 1, numlon_o(jo) - f_ovr = 0. - - do n = 1, mx_ovr - f_ovr = f_ovr + w_ovr(io,jo,n) - end do - - if (abs(f_ovr-1.) .gt. relerr) then - write (6,*) 'AO_I error: area not conserved for',' lon,lat = ', io,jo - write (6,'(a30,e20.10)') ' sum of overlap weights = ', f_ovr - call endrun - end if - - end do - end do - - return -end subroutine ao_i diff --git a/tools/definesurf/area_ave.f90 b/tools/definesurf/area_ave.f90 deleted file mode 100644 index cbcdbcd3af..0000000000 --- a/tools/definesurf/area_ave.f90 +++ /dev/null @@ -1,59 +0,0 @@ -subroutine area_ave (nlat_i , nlon_i , numlon_i, fld_i , & - nlat_o , nlon_o , numlon_o, fld_o , & - i_ovr , j_ovr , w_ovr , nmax ) - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none -! ------------------------ code history --------------------------- -! source file: area_ave.F -! purpose: area averaging of field from input to output grids -! date last revised: November 1996 -! author: Gordon Bonan -! standardized: -! reviewed: -! ----------------------------------------------------------------- - -! ------------------- input variables ----------------------------- - integer nlat_i ! number of latitude points for input grid - integer nlat_o ! number of latitude points for output grid - integer nlon_i ! maximum number of longitude points for input grid - integer nlon_o ! maximum number of longitude points for output grid - integer nmax ! maximum number of overlapping cells - integer numlon_i(nlat_i) ! input grid number of lon points at each lat - integer numlon_o(nlat_o) ! input grid number of lon points at each lat - integer i_ovr(nlon_o,nlat_o,nmax) ! lon index, overlapping input cell - integer j_ovr(nlon_o,nlat_o,nmax) ! lat index, overlapping input cell - - real(r8) fld_i(nlon_i,nlat_i) !field for input grid - real(r8) w_ovr(nlon_o,nlat_o,nmax) ! overlap weights for input cells -! ----------------------------------------------------------------- - -! ------------------- output variables ---------------------------- - real(r8) fld_o(nlon_o,nlat_o) !field for output grid -! ----------------------------------------------------------------- - -! ------------------- local variables ----------------------------- - integer jo,ji !latitude index for output,input grids - integer io,ii !longitude index for output,input grids - integer n !overlapping cell index -! ----------------------------------------------------------------- - - do jo = 1, nlat_o - do io =1, numlon_o(jo) - fld_o(io,jo) = 0. - end do - end do - - do n = 1, nmax - do jo = 1, nlat_o - do io =1, numlon_o(jo) - ii = i_ovr(io,jo,n) - ji = j_ovr(io,jo,n) - fld_o(io,jo) = fld_o(io,jo) + w_ovr(io,jo,n)*fld_i(ii,ji) - end do - end do - end do - - return -end subroutine area_ave diff --git a/tools/definesurf/binf2c.f90 b/tools/definesurf/binf2c.f90 deleted file mode 100644 index f43ca19ee4..0000000000 --- a/tools/definesurf/binf2c.f90 +++ /dev/null @@ -1,218 +0,0 @@ -subroutine binf2c(flon , flat ,nflon ,nflat ,fine , & - clon , clat ,nclon ,nclat ,cmean ) - - use shr_kind_mod, only: r8 => shr_kind_r8 - -!----------------------------------------------------------------------------- -! Bin going from a fine grid to a coarse grid. -! A schematic for the coarse and fine grid systems is shown in -! Figure 1. This code assumes that each data point is represent -! it's surrounding area, called a cell. The first grid data point -! for both grids is assumed to be located at 0E (GM). This -! implies that the 1st cell for both the fine and the coarse grids -! strattles the Greenwich Meridian (GM). This code also assumes -! that there is no data wraparound (last data value is located at -! 360-dx). -! -! FIGURE 1: Overview of the coarse (X) and fine (@) grids -! longitudinal structure where: -! X = location of each coarse grid data point -! @ = location of each fine grid data point -! -! Greenwich Greenwich -! 0 Coarse cells 360 -! : v : -! clon(1): clon(2) v clon(3) clon(nclon): -! v : v v v v : -! xxxxxxxxxxxxxxxxxxxxxxxxxxxx..xxxxxxxxxxxxxxxx : -! x x x x x : -! x x x x x : -! x c(1) x c(2) x x c(nclon)x : -! x X x X x x X x : -! x ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ : -! x | | | | | | | | | | | | | : -! x | @ | @ | @ | @ | @ | @ |..| @ | @ | @ | @ | @ | : -! xxx|___|___|___|___|___|___| |___|___|___|___|___| : -! v v v v v : -! flon(1) flon(3) v flon(nflon-1) flon(nflon) -! : v : -! : Fine cells : -! 0 360 -! -! The Longitude/Latitude search: -! ------------------------------ -! -! Given a coarse grid cell with west and east boundaries of cWest -! and cEast and south and north boundaries of cSouth and cNorth -! (outlined by "x" in figure 2), find the indices of the fine grid -! points which are contained within the coarse grid cell. imin and -! imax are the indices fine grid points which overlap the western -! and eastern boundary of the coarse cell. jmin and jmax are the -! corresponding indices in the S-N direction. Bin these overlapping -! values to generate coarse(n), the coarse grid data values. -! -! FIGURE 2: Detail of Coarse and Fine cell overlap. -! @ = fine grid data point -! X = coarse grid data point -! -! cWest cEast -! | | x | | x | -! -@-------@---x---@-------@-----x-@- -! | | x*xxxxxxxxxxxxxxxxx*x|xx cNorth -! | | x | | x | -! | | x | | x | -! @-------@---x---@-------@-----x-@- jmax -! | | x | c(n) | x | -! | @ | x | | x | -! | | x | | x | -! @-------@---x---@-------@-----x-@- jmin -! | | x | | x | -! | @ | x*xxxxxxx@xxxxxxxxx*x|xx cSouth -! | | x | | x | -! -@-------@---x---@-------@-----x-@- -! | imin imax | -! -! -! When a cell coarse cell strattles the Greenwich Meridian -! --------------------------------------------------------- -! -! The first coarse grid cell strattles the GM, so when the western -! boundary of the coarse cell is < 0, an additional search is carried out. -! It ASSUMES that the easternmost fine grid point overlaps and searches -! westward from nflon, looking for a grid point west of clon(1) -! This generates a second set of longitudinal indices, imin1 and imax1. -! See Figure 3. -! -! Figure 3: Detail of Coarse cell strattling GM: -! ----------------------------------------------- -! -! Greenwich Greenwich -! 0 360 -! cWest : cEast cWest : -! clon(1): clon(2) clon(nclon+1)=clon(1) -! v : v v : -! xxxxxxxxxxxxxxxxxxxxxxx ... xxxxxxxxxxxxxxxx : -! x x x x x : -! x x x x x : -! x c(1) x x x c(nclon)x : -! x X x x x X x : -! x ___ ___ ___ _ ___ ___ ___ : -! x | | | | | | | : -! x | @ | @ | @ | @ | @ | @ | : -! xxx|___|___|___|_ ___|___|___| : -! ^ : ^ ^ ^ ^ : -! flon(1): ^ flon(3) flon(nflon-1) ^ : -! ^ : ^ ^ ^ : -! ^ :flon(2) ^ flon(nflon) -! ^ : ^ ^ ^ : -! imin : imax imin1 imax1 : -! : : -! -! -! In this case, imin=1, imax=2, imin1=nflon-1 and imax1=nflon. -! because the last two cells of the fine grid will have some -! contribution the the 1st cell of the coarse grid. -! -!----------------------------------------------------------------------- - implicit none -!-----------------------------Arguments--------------------------------- - - integer nflon ! Input: number of fine longitude points - integer nflat ! Input: number of fine latitude points - integer nclon ! Input: number of coarse longitude points - integer nclat ! Input: number of coarse latitude points - - real(r8) flon(nflon) ! Input: fine grid lons, centers (deg) - real(r8) flat(nflat) ! Input: fine grid lats, centers (deg) - real(r8) fine(nflon,nflat) ! Input: Fine grid data array - real(r8) clon(nclon+1,nclat) ! Input: coarse grid cell lons, west edge (deg) - real(r8) clat(nclat+1) ! Input: coarse grid cell lat, south edge (deg) - real(r8) cmean(nclon,nclat) ! Output: mean of fine grid points over coarse cell - -!--------------------------Local variables------------------------------ - - real(r8) cWest ! Coarse cell longitude, west edge (deg) - real(r8) cEast ! Coarse cell longitude, east edge (deg) - real(r8) cSouth ! Coarse cell latitude, south edge (deg) - real(r8) cNorth ! Coarse cell latitude, notrh edge (deg) - real(r8) sum ! coarse tmp value - - integer i,j ! Indices - integer imin ,imax ! Max/Min E-W indices of intersecting fine cell. - integer imin1,imax1 ! fine E-W indices when coarse cell strattles GM - integer jmin ,jmax ! Max/Min N-S indices of intersecting fine cell. - integer iclon,jclat ! coarse grid indices - integer num ! increment - -!----------------------------------------------------------------------------- - - do jclat= 1,nclat ! loop over coarse latitudes - cSouth = clat(jclat) - cNorth = clat(jclat+1) - - do iclon=1,nclon ! loop over coarse longitudes - cWest = clon(iclon,jclat) - cEAST = clon(iclon+1,jclat) - -! 1. Normal longitude search: Find imin and imax - - imin = 0 - imax = 0 - do i=1,nflon-1 ! loop over fine lons, W -> E - if (flon(i) .gt. cEast) goto 10 ! fine grid point is E of coarse box - if (flon(i) .ge. cWest .and. imin.eq.0) imin=i - imax=i - enddo - -! 2. If cWest < 0, then coarse cell strattles GM. Hunt westward -! from the end to find indices of any overlapping fine grid cells: -! imin1 and imax1. - -10 imin1 = 0 ! borders for cWest, cEast - imax1 = -1 ! borders for cWest, cEast - if (cWest .lt. 0) then - cWest = cWest + 360. - imax1 = nflon - do i=nflon,1,-1 ! loop over fine lons, E -> W - imin1=i - if (flon(i) .le. cWest) goto 20 ! fine grid point is W of coarse box - enddo - endif - -! 3. Do the latitude search S -> N for jmin and jmax - -20 jmin = 0 - jmax = 0 - do j=1,nflat ! loop over fine lats, S -> N - if (flat(j) .gt. cNorth) goto 30 ! fine grid point is N of coarse box - if (flat(j) .ge. cSouth .and. jmin.eq.0) jmin=j - jmax=j - enddo -30 continue - -! 4. Sum - - sum = 0. ! Initialize coarse data value - num = 0 - - do j=jmin,jmax ! loop over fine lats, S -> N - do i=imin,imax ! loop over fine lons, W -> E - sum = sum + fine(i,j) - num = num + 1 - enddo - do i=imin1,imax1 ! If coarse cell strattles GM - sum = sum + fine(i,j) - num = num + 1 - enddo - enddo - - if (num .gt. 0) then - cmean(iclon,jclat) = sum/num - else - cmean(iclon,jclat) = 1.e30 - endif - - end do - end do - return -end subroutine binf2c diff --git a/tools/definesurf/cell_area.f90 b/tools/definesurf/cell_area.f90 deleted file mode 100644 index 2e8272aaeb..0000000000 --- a/tools/definesurf/cell_area.f90 +++ /dev/null @@ -1,51 +0,0 @@ -subroutine cell_area (nlat, nlon, numlon, lon_w, lat_s, re, area) - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none -! ------------------------ code history --------------------------- -! source file: cell_area.F -! purpose: area of grid cells -! date last revised: March 1996 -! author: Gordon Bonan -! standardized: -! reviewed: -! ----------------------------------------------------------------- - -! ------------------- input variables ----------------------------- - integer nlat !number of latitude points - integer nlon !maximum number of longitude points - integer numlon(nlat) !number of longitude points for each latitude - real(r8) lon_w(nlon+1,nlat) !grid cell longitude, western edge (degrees) - real(r8) lat_s(nlat+1) !grid cell latitude, southern edge (degrees) -! ----------------------------------------------------------------- - -! ------------------- output variables ---------------------------- - real(r8) re !radius of earth (km) - real(r8) area(nlon,nlat) !cell area (km**2) -! ----------------------------------------------------------------- - -! ------------------- local variables ----------------------------- - integer i !longitude index - integer j !latitude index - - real(r8) dx !cell width - real(r8) dy !cell length - real(r8) deg2rad !pi/180 - real(r8) one - parameter (one=1.) ! Argument to atan -! ----------------------------------------------------------------- - - deg2rad = (4.*atan(one)) / 180. - re = 6371.227709 - - do j = 1, nlat - do i = 1, numlon(j) - dx = (lon_w(i+1,j)-lon_w(i,j)) * deg2rad - dy = sin(lat_s(j+1)*deg2rad) - sin(lat_s(j)*deg2rad) - area(i,j) = dx*dy*re*re - end do - end do - - return -end subroutine cell_area diff --git a/tools/definesurf/chkdims.f90 b/tools/definesurf/chkdims.f90 deleted file mode 100644 index cb9be4ce32..0000000000 --- a/tools/definesurf/chkdims.f90 +++ /dev/null @@ -1,52 +0,0 @@ -subroutine chkdims (fileid, name, varid, londimid, latdimid, timdimid, verbose) - - implicit none - - include 'netcdf.inc' - - integer fileid, varid, londimid, latdimid - integer timdimid - logical verbose - character*(*) name - - integer ret - integer ndims, dimids(nf_max_dims) - - ret = nf_inq_varid (fileid, name, varid) - - if (ret.eq.NF_NOERR) then - - dimids(:) = -999 - ret = nf_inq_varndims (fileid, varid, ndims) - ret = nf_inq_vardimid (fileid, varid, dimids) - - if (ret.ne.NF_NOERR) then - write(6,*)'NF_INQ_VAR failed for ',name - call handle_error (ret) - end if - - if (ndims.eq.3 .and. dimids(3).ne.timdimid) then - write(6,*)'3rd dim of ', name, ' must be time' - call endrun - end if - - if (dimids(1).ne.londimid .or. dimids(2).ne.latdimid) then - write(6,*)'Dims of ', name,' must be lon by lat' - call endrun - end if - - if (verbose) write(6,*)'Overwriting existing ',name,' with hi-res topo' - - else - - dimids(1) = londimid - dimids(2) = latdimid - dimids(3) = timdimid - if (verbose) write(6,*)name,' does not exist on netcdf file: Creating.' - ret = nf_redef (fileid) - ret = nf_def_var (fileid, name, NF_DOUBLE, 3, dimids, varid) - if (ret.ne.NF_NOERR) call handle_error (ret) - ret = nf_enddef (fileid) - - end if -end subroutine chkdims diff --git a/tools/definesurf/endrun.f90 b/tools/definesurf/endrun.f90 deleted file mode 100644 index 71b2194a6f..0000000000 --- a/tools/definesurf/endrun.f90 +++ /dev/null @@ -1,7 +0,0 @@ -subroutine endrun - implicit none - include 'netcdf.inc' - - call abort - stop 999 -end subroutine endrun diff --git a/tools/definesurf/fmain.f90 b/tools/definesurf/fmain.f90 deleted file mode 100644 index c14b337c64..0000000000 --- a/tools/definesurf/fmain.f90 +++ /dev/null @@ -1,458 +0,0 @@ -program fmain - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - include 'netcdf.inc' -! -! Local workspace -! - real(r8), parameter :: fillvalue = 1.d36 - real(r8), parameter :: filter_coefficient = 0.25D0 - - character(len=128) :: topofile = ' ' ! input high resolution (10 min) file name - character(len=128) :: landmfile = ' ' ! input land mask file name - character(len=128) :: gridfile = ' ' ! input initial condition file with grid definition - character(len=128) :: outbcfile = ' ' ! output boundary condition file with PHIS, SGH, etc. - character(len= 80) :: arg ! used for parsing command line arguments - character(len=256) :: cmdline ! input command line - character(len=256) :: history ! history attribute text - character(len= 8) :: datestring - character(len= 32) :: z_filter_type ! type of filter applied to height - character(len= 32) :: s_filter_type ! type of filter applied to standard deviations - - logical verbose ! Add print statements - logical make_ross ! Make Ross ice shelf south of -79 - logical filter_del2 ! Execute SJ Lin's del2 terrain filter - logical filter_remap ! Execute SJ Lin's newer remapping terrain filter - logical filter_sgh ! Filter SGH and SGH30 in addition to height - logical reduced_grid ! reduced grid defined - logical have_sgh30 ! input topofile has sgh30, output will also - - integer cmdlen ! character array lengths - integer gridid - integer foutid ! output file id - integer lonid, londimid, rlonid ! longitude dimension variable ids - integer latid, latdimid ! latitude dimension variable ids - integer sghid, phisid, landfid, nlonid, landmid, sgh30id ! output variable netcdf ids - integer start(4), count(4) - integer plon, nlat - integer i, j - integer ret - integer nargs ! input arg - integer n ! index loops thru input args - - integer dim(2) ! dimension list for output variables - - integer , allocatable :: nlon(:) - real(r8), allocatable :: mlatcnts(:) ! model cell center latitudes - real(r8), allocatable :: mloncnts(:,:) ! model cell center longitudes - real(r8), allocatable :: sgh(:,:) - real(r8), allocatable :: sgh30(:,:) - real(r8), allocatable :: phis(:,:) - real(r8), allocatable :: fland(:,:) - real(r8), allocatable :: landm(:,:) - - integer iargc - external iargc -! -! Default settings before parsing argument list -! - verbose = .false. - make_ross = .true. - filter_del2 = .false. - filter_remap = .false. - filter_sgh = .false. - reduced_grid = .false. - -! parse input arguments - - nargs = iargc() - n = 1 - cmdline = char(10) // 'definesurf ' - do while (n .le. nargs) - arg = ' ' - call getarg (n, arg) - n = n + 1 - - select case (arg) -! topography file name (10') - case ('-t') - call getarg (n, arg) - n = n + 1 - topofile = arg - cmdline = trim(cmdline) // ' -t ' // trim(topofile) -! grid file name - case ('-g') - call getarg (n, arg) - n = n + 1 - gridfile = arg - cmdline = trim(cmdline) // ' -g ' // trim(gridfile) -! verbose mode - case ('-v') - verbose = .true. - cmdline = trim(cmdline) // ' -v' -! landmask file name - case ('-l') - call getarg (n, arg) - n = n + 1 - landmfile = arg - cmdline = trim(cmdline) // ' -l ' // trim(landmfile) -! extend Ross Sea - case ('-r') - make_ross = .false. - cmdline = trim(cmdline) // ' -r' -! use del2 filter on heights - case ('-del2') - filter_del2 = .true. - cmdline = trim(cmdline) // ' -del2' -! use remap filter on heights - case ('-remap') - filter_remap = .true. - cmdline = trim(cmdline) // ' -remap' -! apply filter to sgh (and sgh30) in addition to height - case ('-sgh') - filter_sgh = .true. - cmdline = trim(cmdline) // ' -sgh' -! not one of the above, must be output file name - case default - if (outbcfile .eq. ' ') then - outbcfile = arg - else - write (6,*) 'Argument ', arg,' is not known' - call usage_exit (' ') - end if - cmdline = trim(cmdline) // ' ' // trim(arg) - end select - end do - - if (outbcfile == ' ') then - call usage_exit ('Must enter an output file name') - end if - - if (gridfile == ' ') then - call usage_exit ('Must enter gridfile name via -g arg (can use a model history file)') - end if - - if (topofile == ' ') then - call usage_exit ('Must enter topofile name via -t arg') - end if - - if (filter_remap .and. filter_del2) then - write(6,*)'Both filter_remap and filter_del2 set: using filter_remap' - end if - - if (.not. filter_remap .and. .not. filter_del2) then - write(6,*)'No filter being applied to height field' - if (filter_sgh) call usage_exit ('Must filter height to filter sgh') - end if - - if (landmfile == ' ') then - call usage_exit ('Must enter landmfile name via -l arg') - end if - -! Open the grid file - ret = nf_open (trim(gridfile), nf_nowrite, gridid) - if (ret /= nf_noerr) then - write(6,*)nf_strerror(ret) - write(6,*)'Unable to open input file ', trim(gridfile), ' for writing' - stop 999 - end if - -! Get the grid dimensions from the grid file - call wrap_inq_dimid (gridid, 'lon', londimid) - call wrap_inq_dimlen (gridid, londimid, plon ) - call wrap_inq_dimid (gridid, 'lat', latdimid) - call wrap_inq_dimlen (gridid, latdimid, nlat ) -! -! Get longitude and latitude arrays for model grid. -! If reduced grid, 2-d variable containing lon values for each lat is called "rlon". -! First allocate space for dynamic arrays now that sizes are known -! - allocate (nlon(nlat)) - allocate (mlatcnts(nlat)) - allocate (mloncnts(plon,nlat)) - - if (nf_inq_varid (gridid, 'nlon', nlonid) == nf_noerr) then - if (nf_get_var_int (gridid, nlonid, nlon) /= nf_noerr) then - write(6,*)'nf_get_var_int() failed for nlon' - call endrun - end if - reduced_grid = .true. - else - nlon(:) = plon - end if - - do j=1,nlat - if (nlon(j)<1 .or. nlon(j)>plon) then - write(6,*)'nlon(',j,')=',nlon(j),' is invalid.' - write(6,*)'Must be between 1 and ',plon - call endrun - end if - end do - - call wrap_inq_varid (gridid, 'lat', latid) - call wrap_get_var8 (gridid, latid, mlatcnts) - - if (nf_inq_varid (gridid, 'lon', lonid) == nf_noerr) then - call wrap_get_var8 (gridid, lonid, mloncnts(1,1)) - do j=2,nlat - mloncnts(:,j) = mloncnts(:,1) - end do - else - call wrap_inq_varid (gridid, 'rlon', rlonid) - call wrap_get_var8 (gridid, rlonid, mloncnts) - end if - -! Close the grid file - if (nf_close (gridid) == nf_noerr) then - write(6,*) 'close grid file ', trim(gridfile) - else - write(6,*) 'ERROR CLOSING NETCDF FILE ',trim(gridfile) - end if -! -! Allocate space for variables -! - allocate (sgh(plon,nlat)) - allocate (sgh30(plon,nlat)) - allocate (phis(plon,nlat)) - allocate (fland(plon,nlat)) - allocate (landm(plon,nlat)) -! -! Determine model topographic height and 2 standard deviations -! - call sghphis (plon, nlat, nlon, mlatcnts, mloncnts, topofile, & - verbose, sgh, sgh30, have_sgh30, phis, fland) - -! Do the terrain filter. -! Note: not valid if a reduced grid is used. - if (filter_remap) then - z_filter_type = 'remap' - write(6,*)'Remapping terrain filtering' -! 7 and 3 are the recommended mapping accuracy settings - call map2f (plon, nlat, phis, 7, 3, .true.) - if (filter_sgh) then - s_filter_type = 'remap' - write(6,*)'Filtering standard deviation' - call map2f (plon, nlat, sgh, 7, 3, .true.) - if(have_sgh30) call map2f(plon, nlat, sgh30, 7, 3, .true.) - else - s_filter_type = 'none (2x[1-2-1])' - write(6,*)'Not filtering standard deviation' - end if - else if (filter_del2) then - z_filter_type = 'del2' - write(6,*) 'Del2 Terrain filtering' - call sm2(plon, nlat, phis, plon/12, filter_coefficient) - if (filter_sgh) then - s_filter_type = 'del2' - write(6,*)'Filtering standard deviation' - call sm2(plon, nlat, sgh, plon/12, filter_coefficient) - if(have_sgh30) call sm2(plon, nlat, sgh30, plon/12, filter_coefficient) - else - s_filter_type = 'none (2x[1-2-1])' - write(6,*)'Not filtering standard deviation' - end if - else - z_filter_type = 'none' - s_filter_type = 'none (2x[1-2-1])' - endif -! -! Adjustments to land fraction: -! 1. Extend land fraction for Ross Ice shelf -! 2. Set land fractions < .001 to 0.0 -! 3. flag regions outside reduced grid -! - do j=1,nlat - do i=1,nlon(j) -! -! Overwrite FLAND flag as land for Ross ice shelf - if (make_ross .and. mlatcnts(j) < -79.) then - fland(i,j) = 1. - end if - - if (fland(i,j) < .001_r8) fland(i,j) = 0.0 - - end do -! -! Fill region outside reduced grid with flag values - do i=nlon(j)+1,plon - sgh(i,j) = fillvalue - if(have_sgh30) sgh30(i,j) = fillvalue - phis(i,j) = fillvalue - fland(i,j) = fillvalue - landm(i,j) = fillvalue - end do - end do -! -! Calculate LANDM field required by cloud water. -! -!JR Replace original resolution-dependent calculation with interpolation. -!JR -!JR call inimland (plon, nlat, nlon, mlatcnts, mloncnts, topofile, & -!JR verbose, make_ross, landm) -! - call interplandm (plon, nlat, nlon, mlatcnts, mloncnts, & - landmfile, landm) - -! Create NetCDF file for output - ret = nf_create (outbcfile, NF_CLOBBER, foutid) - if (ret .ne. NF_NOERR) call handle_error(ret) - -! Create dimensions for output - call wrap_def_dim (foutid, 'lon', plon, lonid) - call wrap_def_dim (foutid, 'lat', nlat, latid) - dim(1)=lonid - dim(2)=latid - -! Create latitude dimension variable for output - ret = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latdimid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_text (foutid,latdimid,'long_name', 'latitude') - call wrap_put_att_text (foutid,latdimid,'units' , 'degrees_north') - -! Create longitude dimension variable for output - if (.not.reduced_grid) then - ret = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, londimid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_text (foutid,londimid,'long_name', 'longitude') - call wrap_put_att_text (foutid,londimid,'units' , 'degrees_east') - -! For reduced grid, add longitude limits (nlon) and lons (rlon) - else - ret = nf_def_var (foutid,'nlon', NF_INT, 1, lonid, londimid) - if (ret .ne. NF_NOERR) call handle_error(ret) - ret = nf_def_var (foutid,'rlon', NF_DOUBLE, 2, dim, rlonid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_text (foutid,rlonid,'long_name', 'longitude') - call wrap_put_att_text (foutid,rlonid,'units' , 'degrees_east') - end if - -! Create variables for output - ret = nf_def_var (foutid,'PHIS' , NF_DOUBLE, 2, dim, phisid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_double (foutid, phisid, '_FillValue', nf_double, 1, fillvalue) - call wrap_put_att_double (foutid, phisid, 'missing_value', nf_double, 1, fillvalue) - call wrap_put_att_text (foutid, phisid, 'long_name' , 'surface geopotential') - call wrap_put_att_text (foutid, phisid, 'units' , 'm2/s2') - call wrap_put_att_text (foutid, phisid, 'from_hires', 'true') - call wrap_put_att_text (foutid, phisid, 'filter' , z_filter_type) - - ret = nf_def_var (foutid,'SGH' , NF_DOUBLE, 2, dim, sghid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_double (foutid, sghid, '_FillValue', nf_double, 1, fillvalue) - call wrap_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) - call wrap_put_att_text (foutid, sghid, 'long_name' , 'standard deviation of 10-min elevations') - call wrap_put_att_text (foutid, sghid, 'units' , 'm') - call wrap_put_att_text (foutid, sghid, 'from_hires', 'true') - call wrap_put_att_text (foutid, sghid, 'filter' , s_filter_type) - - if (have_sgh30) then - ret = nf_def_var (foutid,'SGH30' , NF_DOUBLE, 2, dim, sgh30id) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_double (foutid, sgh30id, '_FillValue', nf_double, 1, fillvalue) - call wrap_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) - call wrap_put_att_text (foutid, sgh30id, 'long_name' , 'standard deviation of elevation from 30s to 10m') - call wrap_put_att_text (foutid, sgh30id, 'units' , 'm') - call wrap_put_att_text (foutid, sgh30id, 'from_hires', 'true') - call wrap_put_att_text (foutid, sgh30id, 'filter' , s_filter_type) - endif - - ret = nf_def_var (foutid,'LANDFRAC' , NF_DOUBLE, 2, dim, landfid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_double (foutid, landfid, '_FillValue', nf_double, 1, fillvalue) - call wrap_put_att_double (foutid, landfid, 'missing_value', nf_double, 1, fillvalue) - call wrap_put_att_text (foutid, landfid, 'long_name' , 'gridbox land fraction') - call wrap_put_att_text (foutid, landfid, 'from_hires', 'true') - - ret = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 2, dim, landmid) - if (ret .ne. NF_NOERR) call handle_error(ret) - call wrap_put_att_double (foutid, landmid, '_FillValue', nf_double, 1, fillvalue) - call wrap_put_att_double (foutid, landmid, 'missing_value', nf_double, 1, fillvalue) - call wrap_put_att_text (foutid, landmid, 'long_name' , & - 'land ocean transition mask: ocean (0), continent (1), transition (0-1)') - call wrap_put_att_text (foutid, landmid, 'from_hires', 'true') - -! Define history attribute. - call DATE_AND_TIME(DATE=datestring) - history = 'Written on date: ' // datestring // cmdline - call wrap_put_att_text (foutid, nf_global, 'history', history) - -! Define Ross Sea attribute - if (make_ross) then - write (6,*) 'Extending Ross ice shelf south of -79 degrees' - call wrap_put_att_text (foutid, nf_global, 'make_ross', 'true') - else - write (6,*) 'Not doing anything special for Ross ice shelf' - call wrap_put_att_text (foutid, nf_global, 'make_ross', 'false') - end if - -! Define source file attributes - call wrap_put_att_text (foutid, nf_global, 'topofile', topofile) - cmdlen = len_trim (gridfile) - call wrap_put_att_text (foutid, nf_global, 'gridfile', gridfile) - cmdlen = len_trim (landmfile) - call wrap_put_att_text (foutid, nf_global, 'landmask', landmfile) - - -! End definition of netCDF file - ret = nf_enddef (foutid) - if (ret/=NF_NOERR) call handle_error (ret) - - -! Write data to file - write(6,*) 'Writing surface quantities' - -! Write dimension variables - call wrap_put_var8 (foutid, latdimid, mlatcnts) - if (.not.reduced_grid) then - call wrap_put_var8 (foutid, londimid, mloncnts(:,1)) - else - ret = nf_put_var_int (foutid, nlonid, nlon) - if (ret/=NF_NOERR) call handle_error (ret) - call wrap_put_vara8 (foutid, rlonid, start, count, mloncnts) - end if - - start(:) = 1 - count(1) = plon - count(2) = nlat - count(3:) = 1 - - call wrap_put_vara8 (foutid, sghid, start, count, sgh) - if(have_sgh30) call wrap_put_vara8 (foutid, sgh30id, start, count, sgh30) - call wrap_put_vara8 (foutid, phisid , start, count, phis) - call wrap_put_vara8 (foutid, landfid, start, count, fland) - call wrap_put_vara8 (foutid, landmid, start, count, landm) - - if (nf_close (foutid) == nf_noerr) then - write(6,*) 'Successfully defined surface quantities on ', trim(outbcfile) - else - write(6,*) 'ERROR CLOSING NETCDF FILE ',trim(outbcfile) - end if - - deallocate (nlon) - deallocate (mlatcnts) - deallocate (mloncnts) - deallocate (sgh) - deallocate (sgh30) - deallocate (phis) - deallocate (fland) - deallocate (landm) - - stop 0 -end program fmain - -subroutine usage_exit (arg) - implicit none - character*(*) arg - - if (arg /= ' ') write (6,*) arg - write (6,*) 'Usage: definesurf -t topofile -g gridfile -l landmfile [-v] [-r] [-del2] [-remap] outfile' - write (6,*) ' -v verbose mode' - write (6,*) ' -r Do *not* extend Ross Ice Shelf as land ice' - write (6,*) ' -del2 use del2 terrain filter (not a valid option for reduced grid)' - write (6,*) ' -remap use remapping filter (not a valid option for reduced grid)' - write (6,*) ' -sgh filter sgh and sgh30 using same terrain filter' - stop 999 -end subroutine usage_exit diff --git a/tools/definesurf/handle_error.f90 b/tools/definesurf/handle_error.f90 deleted file mode 100644 index 519f829097..0000000000 --- a/tools/definesurf/handle_error.f90 +++ /dev/null @@ -1,11 +0,0 @@ -subroutine handle_error (ret) - implicit none - - integer ret - - include 'netcdf.inc' - - write(6,*) nf_strerror (ret) - call abort - stop 999 -end subroutine handle_error diff --git a/tools/definesurf/inimland.f90 b/tools/definesurf/inimland.f90 deleted file mode 100644 index af929f1b98..0000000000 --- a/tools/definesurf/inimland.f90 +++ /dev/null @@ -1,205 +0,0 @@ -subroutine inimland (plon, nlat, nlon_reduced, mlatcnts, mloncnts, topofile, & - verbose, make_ross, landm_reduced) - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none -! -! Input arguments -! - integer , intent(in) :: plon ! number of longitudes - integer , intent(in) :: nlat ! number of latitudes - integer , intent(in) :: nlon_reduced(nlat) ! number of reduced latitudes - real(r8), intent(in) :: mlatcnts(nlat) ! latitude at center of grid cell - real(r8), intent(in) :: mloncnts(plon,nlat) ! model cell ceneter longitudes - character(len=*), intent(in) :: topofile ! high res topo file - logical, intent(in) :: verbose ! verbose output - logical, intent(in) :: make_ross ! flag to make Ross ice shelf -! -! Output arguments -! - real(r8), intent(out) :: landm_reduced(plon,nlat) ! landm on reduced grid - -! Local variables - - real(r8) landm(plon,nlat) ! landm on full grid - real(r8) clon(plon) - real(r8) clon_reduced(plon,nlat) - real(r8) cont(plon,nlat) - real(r8) temp(plon,nlat) - real(r8) dmax - real(r8) arad - real(r8) dist - real(r8) sum - real(r8) cs(nlat) - real(r8) ss(nlat) - real(r8) c1 - real(r8) s1 - real(r8) c2 - real(r8) s2 - real(r8) dx - real(r8) dy - real(r8) term - real(r8) pi - real(r8) sgh(plon,nlat) ! required by SGHPHIS (unused locally) - real(r8) phis(plon,nlat) ! required by SGHPHIS (unused locally) - real(r8) oro(plon,nlat) ! land/ocean flag - real(r8) fland(plon,nlat) ! land fraction output from SGHPHIS - real(r8) mloncnts_full(plon,nlat) ! longitudes for rectangular grid - - integer i - integer j - integer ii - integer jj - integer iplm1 - integer jof - integer iof - integer itmp - integer jmin, jmax - integer nlon(nlat) - integer latid - - pi = acos(-1.d0) -! -! Define longitudes for a rectangular grid: index nlat/2+1 will be a latitude -! closest to the equator, i.e. with the most points in a reduced grid. -! - nlon(:) = plon - do j=1,nlat - mloncnts_full(:,j) = mloncnts(:,nlat/2+1) - end do - - call sghphis (plon, nlat, nlon, mlatcnts, mloncnts_full, topofile, & - verbose, sgh, phis, fland) -! -! Define land mask. Set all non-land points to ocean (i.e. not sea ice). -! - where (fland(:,:) >= 0.5) - oro(:,:) = 1. - elsewhere - oro(:,:) = 0. - endwhere -! -! Overwrite ORO flag as land for Ross ice shelf: note that the ORO field -! defined in this routine is only used locally. -! - do j=1,nlat - if (make_ross .and. mlatcnts(j) < -79.) then - do i=1,plon - oro(i,j) = 1. - end do - end if - end do -! -! Code lifted directly from cldwat.F -! - dmax = 2.e6 ! distance to carry the mask - arad = 6.37e6 - do i = 1,plon - clon(i) = 2.*(i-1)*pi/plon - end do -! -! first isolate the contenents -! as land points not surrounded by ocean or ice -! - do j = 1,nlat - cs(j) = cos(mlatcnts(j)*pi/180.) - ss(J) = sin(mlatcnts(j)*pi/180.) - do i = 1,plon - cont(i,j) = 0. - if (nint(oro(i,j)) .eq. 1) then - cont(i,j) = 1. - endif - end do - temp(1,j) = cont(1,j) - temp(plon,j) = cont(plon,j) - end do - - do i = 1,plon - temp(i,1) = cont(i,1) - temp(i,nlat) = cont(i,nlat) - end do -! -! get rid of one and two point islands -! - do j = 2,nlat-1 - do i = 2,plon-1 - sum = cont(i ,j+1) + cont(i ,j-1) & - + cont(i+1,j+1) + cont(i+1,j-1) & - + cont(i-1,j+1) + cont(i-1,j-1) & - + cont(i+1,j ) + cont(i-1,j) & - + cont(i ,j ) - if (sum.le.2.) then - temp(i,j) = 0. - else - temp(i,j) = 1. - endif - enddo - end do - - do j = 1,nlat - do i = 1,plon - cont(i,j) = temp(i,j) - end do - end do -! -! construct a function which is one over land, -! zero over ocean points beyond dmax from land -! - iplm1 = 2*plon - 1 - dy = pi*arad/nlat - jof = dmax/dy + 1 -! write (6,*) ' lat bands to check ', 2*jof+1 - do j = 1,nlat - c1 = cs(j) - s1 = ss(j) - dx = 2*pi*arad*cs(j)/plon -! -! if dx is too small, int(dmax/dx) may exceed the maximum size -! of an integer, especially on Suns, causing a core dump. Test -! to avoid that. -! - if (dx .lt. 1. .and. dmax .gt. 10000.) then - iof = plon - else - iof = min(int(dmax/dx) + 1, plon) - end if - do i = 1,plon - temp(i,j) = 0. - landm(i,j) = 0. - jmin = max(1,j-jof) - jmax = min(nlat,j+jof) - do jj = jmin, jmax - s2 = ss(jj) - c2 = cs(jj) - do itmp = -iof,iof - ii = mod(i+itmp+iplm1,plon)+1 - term = s1*s2 + c1*c2*cos(clon(ii)-clon(i)) - if (term.gt.0.9999999) term = 1. - dist = arad*acos(term) - landm(i,j) = max(landm(i,j), (1.-dist/dmax)*cont(ii,jj)) -! if (dist.lt.dmax .and. cont(ii,jj).eq.1) then -! landm(i,j) = max(landm(i,j), 1.-dist/dmax) -! endif - end do - end do - end do - end do -! -! Interpolate to reduced grid. Redefine clon in terms of degrees for interpolation -! - do i = 1,plon - clon(i) = (i-1)*360./plon - end do - do j=1,nlat - do i=1,nlon_reduced(j) - clon_reduced(i,j) = (i-1)*360./nlon_reduced(j) - end do - end do - - do j=1,nlat - call lininterp (landm(1,j), plon, 1, clon, & - landm_reduced(1,j), nlon_reduced(j), 1, clon_reduced(1,j), .true.) - end do - - return - end diff --git a/tools/definesurf/interplandm.f90 b/tools/definesurf/interplandm.f90 deleted file mode 100644 index 88e5fd3d17..0000000000 --- a/tools/definesurf/interplandm.f90 +++ /dev/null @@ -1,92 +0,0 @@ -subroutine interplandm (plono, nlato, nlono, lato, rlono, & - landmfile, landmo) -! -! Read LANDM_COSLAT from input file and interpolate to output grid. -! The input grid is assumed rectangular, but the output grid may -! be reduced. -! - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - include 'netcdf.inc' -! -! Input arguments -! - integer , intent(in) :: plono ! output longitude dimension - integer , intent(in) :: nlato ! number of latitudes - integer , intent(in) :: nlono(nlato) ! number of reduced latitudes - real(r8), intent(in) :: lato(nlato) ! latitude at center of grid cell - real(r8), intent(in) :: rlono(plono,nlato) ! longitude on (potentially reduced) output grid - character(len=*), intent(in) :: landmfile ! file containing input LANDM_COSLAT -! -! Output arguments -! - real(r8), intent(out) :: landmo(plono,nlato) ! landm on reduced grid - -! Local variables - - integer :: nloni - integer :: nlati - integer :: i,j ! spatial indices - integer :: ret ! return code - - integer :: landmfileid ! netcdf file id for landm file - integer :: londimid, latdimid ! lon, lat dimension ids - integer :: lonid, latid ! lon, lat var ids - integer :: landmid ! landm variable id - - real(r8), allocatable :: landmi(:,:) ! landm on full grid - real(r8), allocatable :: lati(:) - real(r8), allocatable :: loni(:) - real(r8), allocatable :: xtemp(:,:) ! temporary for interpolation - - ret = nf_open (landmfile, nf_nowrite, landmfileid) - if (ret /= nf_noerr) then - write(6,*)nf_strerror(ret) - write(6,*)'Unable to open input file ', trim (landmfile) - stop 999 - end if -! -! Retrieve grid info and LANDM_COSLAT field from from offline file. -! - call wrap_inq_dimid (landmfileid, 'lat', latdimid) - call wrap_inq_dimlen (landmfileid, latdimid, nlati) - - call wrap_inq_dimid (landmfileid, 'lon', londimid) - call wrap_inq_dimlen (landmfileid, londimid, nloni) - - allocate (lati(nlati)) - allocate (loni(nloni)) - allocate (landmi(nloni,nlati)) - - call wrap_inq_varid (landmfileid, 'lat', latid) - call wrap_get_var8 (landmfileid, latid, lati) - - call wrap_inq_varid (landmfileid, 'lon', lonid) - call wrap_get_var8 (landmfileid, lonid, loni) - - call wrap_inq_varid (landmfileid, 'LANDM_COSLAT', landmid) - call wrap_get_var8 (landmfileid, landmid, landmi) - - allocate (xtemp(nloni,nlato)) -! -! For rectangular -> reduced, interpolate first in latitude, then longitude -! - do i=1,nloni - call lininterp (landmi(i,1), nlati, nloni, lati, & - xtemp(i,1), nlato, nloni, lato, .false.) - end do - - do j=1,nlato - call lininterp (xtemp(1,j), nloni, 1, loni, & - landmo(1,j), nlono(j), 1, rlono(1,j), .true.) - end do - - deallocate (xtemp) - deallocate (lati) - deallocate (loni) - deallocate (landmi) - - return -end subroutine interplandm diff --git a/tools/definesurf/lininterp.f90 b/tools/definesurf/lininterp.f90 deleted file mode 100644 index 9d5d9d9e76..0000000000 --- a/tools/definesurf/lininterp.f90 +++ /dev/null @@ -1,174 +0,0 @@ -subroutine lininterp (arrin, nxin, incin, xin, & - arrout, nxout, incout, xout, periodic) - use shr_kind_mod, only: r8 => shr_kind_r8 - -!----------------------------------------------------------------------- -! -! Do a linear interpolation from input mesh defined by xin to output -! mesh defined by xout. Where extrapolation is necessary, values will -! be copied from the extreme edge of the input grid. -! -!---------------------------Code history-------------------------------- -! -! Original version: J. Rosinski -! -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- -! -! Arguments -! - integer nxin, incin - integer nxout, incout - - real(r8) xin(nxin), xout(nxout) - real(r8) arrin(incin,nxin) - real(r8) arrout(incout,nxout) - - logical periodic -! -! Local workspace -! - integer i, ii ! input grid indices - integer im, ip, iiprev ! input grid indices - integer icount ! number of values - - real(r8) extrap ! percent grid non-overlap - real(r8) dxinwrap ! delta-x on input grid for 2-pi - real(r8) avgdxin ! avg input delta-x - real(r8) ratio ! compare dxinwrap to avgdxin -! -! Dynamic -! - integer iim(nxout) ! interp. indices minus - integer iip(nxout) ! interp. indices plus - - real(r8) wgtm(nxout) ! interp. weight minus - real(r8) wgtp(nxout) ! interp. weight plus -! -! Just copy the data and return if input dimensions are 1 -! - if (nxin.eq.1 .and. nxout.eq.1) then - arrout(1,1) = arrin(1,1) - else if (nxin.eq.1) then - write(6,*)'LININTERP: Must have at least 2 input points' - call abort - end if - icount = 0 - do i=1,nxin-1 - if (xin(i).gt.xin(i+1)) icount = icount + 1 - end do - do i=1,nxout-1 - if (xout(i).gt.xout(i+1)) icount = icount + 1 - end do - if (icount.gt.0) then - write(6,*)'LININTERP: Non-monotonic coordinate array(s) found' - call abort - end if -! -! Initialize index arrays for later checking -! - do i=1,nxout - iim(i) = 0 - iip(i) = 0 - end do - if (periodic) then -! -! Periodic case: for values which extend beyond boundaries, assume -! periodicity and interpolate between endpoints. First check for sane -! periodicity assumption. -! - if (xin(1).lt.0. .or. xin(nxin).gt.360.) then - write(6,*)'LININTERP: For periodic Input x-grid must be between 0 and 360' - call abort - end if - if (xout(1).lt.0. .or. xout(nxout).gt.360.) then - write(6,*)'Output x-grid must be between 0 and 360' - call abort - end if - dxinwrap = xin(1) + 360. - xin(nxin) - avgdxin = (xin(nxin)-xin(1))/(nxin-1.) - ratio = dxinwrap/avgdxin - if (ratio.lt.0.9 .or. ratio.gt.1.1) then - write(6,*)'LININTERP: Insane dxinwrap value =',dxinwrap,' avg=', avgdxin - call abort - end if - do im=1,nxout - if (xout(im).gt.xin(1)) exit - iim(im) = nxin - iip(im) = 1 - wgtm(im) = (xin(1) - xout(im)) /dxinwrap - wgtp(im) = (xout(im)+360. - xin(nxin))/dxinwrap - end do - do ip=nxout,1,-1 - if (xout(ip).le.xin(nxin)) exit - iim(ip) = nxin - iip(ip) = 1 - wgtm(ip) = (xin(1)+360. - xout(ip)) /dxinwrap - wgtp(ip) = (xout(ip) - xin(nxin))/dxinwrap - end do - else -! -! Non-periodic case: for values which extend beyond boundaries, set weights -! such that values will just be copied. -! - do im=1,nxout - if (xout(im).gt.xin(1)) exit - iim(im) = 1 - iip(im) = 1 - wgtm(im) = 1. - wgtp(im) = 0. - end do - do ip=nxout,1,-1 - if (xout(ip).le.xin(nxin)) exit - iim(ip) = nxin - iip(ip) = nxin - wgtm(ip) = 1. - wgtp(ip) = 0. - end do - end if -! -! Loop though output indices finding input indices and weights -! - iiprev = 1 - do i=im,ip - do ii=iiprev,nxin-1 - if (xout(i).gt.xin(ii) .and. xout(i).le.xin(ii+1)) then - iim(i) = ii - iip(i) = ii + 1 - wgtm(i) = (xin(ii+1)-xout(i))/(xin(ii+1)-xin(ii)) - wgtp(i) = (xout(i)-xin(ii))/(xin(ii+1)-xin(ii)) - goto 30 - end if - end do - write(6,*)'LININTERP: Failed to find interp values' -30 iiprev = ii - end do -! -! Check grid overlap -! - extrap = 100.*((im - 1.) + (nxout - ip))/nxout - if (extrap.gt.30.) then - write(6,*)'********LININTERP WARNING:',extrap,' % of output', & - ' grid will have to be extrapolated********' - end if -! -! Check that interp/extrap points have been found for all outputs -! - icount = 0 - do i=1,nxout - if (iim(i).eq.0 .or. iip(i).eq.0) icount = icount + 1 - end do - if (icount.gt.0) then - write(6,*)'LININTERP: Point found without interp indices' - call abort - end if -! -! Do the interpolation -! - do i=1,nxout - arrout(1,i) = arrin(1,iim(i))*wgtm(i) + arrin(1,iip(i))*wgtp(i) - end do - return -end subroutine lininterp - diff --git a/tools/definesurf/map2f.f90 b/tools/definesurf/map2f.f90 deleted file mode 100644 index 1fb58b3f8a..0000000000 --- a/tools/definesurf/map2f.f90 +++ /dev/null @@ -1,1039 +0,0 @@ - subroutine map2f(im, jm, qm, iord, jord, pfilter) -! -! This is a stand alone 2-Grid-Wave filter for filtering the terrain for -! the finite-volume dynamical core -! Developed and coded by S.-J. Lin -! Data Assimilation Office, NASA/GSFC -! - implicit none -! Input - integer, intent(in):: im ! E-W diimension (e.g., 144 for 2.5 deg) - integer, intent(in):: jm ! N-S dimension (S pole to N pole; 91 for 2 deg) - integer, intent(in):: iord ! Mapping accuracy for E-W; recommended value=7 - integer, intent(in):: jord ! Mapping accuracy for N-S; recommended value=3 - logical, intent(in):: pfilter ! Polar filter (set to .T. for normal application) - -! Input/Output - real*8, intent(inout):: qm(im,jm) ! array to be filtered - -! Local - integer im2, jm2 - integer ndeg - real*8, allocatable:: q2(:,:) - real*8, allocatable:: lon1(:) - real*8, allocatable:: lon2(:) - real*8, allocatable:: sin1(:) - real*8, allocatable:: sin2(:) - real*8, allocatable:: qt1(:,:), qt2(:,:) - - real*8 dx1, dx2 - real*8 dy1, dy2 - - integer i, j - real*8 pi - - ndeg = 45 ! starting latitude for polar filter - pi = 4.d0 * datan(1.d0) - - im2 = im / 2 - if (im2*2 /= im) then - write(*,*) 'Stop in map2f; im=', im - stop - endif - - jm2 = (jm-1) / 2 + 1 - - allocate ( qt1(im2,jm) ) - allocate ( qt2(im2,jm2) ) - - allocate ( q2(im2,jm2) ) - allocate ( lon1(im+1) ) - allocate ( lon2(im2+1) ) - allocate ( sin1(jm+1) ) - allocate ( sin2(jm2+1) ) - - dx1 = 360./im - dx2 = 360./im2 - - dy1 = pi/(jm-1) - dy2 = pi/(jm2-1) - - do i=1,im+1 - lon1(i) = dx1 * (-0.5 + (i-1) ) - enddo - - do i=1,im2+1 - lon2(i) = dx2 * (-0.5 + (i-1) ) - enddo - - sin1(1) = -1. - sin2(1) = -1. - - sin1(jm +1) = 1. - sin2(jm2+1) = 1. - - do j=2,jm - sin1(j) = dsin( -0.5*pi + dy1*(-0.5+(j-1)) ) - enddo - - do j=2,jm2 - sin2(j) = dsin( -0.5*pi + dy2*(-0.5+(j-1)) ) - enddo - - call polavg(qm, im, jm, 1, jm) - if( pfilter ) call plft2d(im, jm, qm, 2, jm-1, ndeg) - -!============================== -! From full --> half resolution -!============================== - - call xmap(iord, im, jm, sin1, lon1, qm, im2, lon2, qt1 ) - call ymap(im2, jm, sin1, qt1, jm2, sin2, qt2, 0, jord) - -!============================== -! From half --> full resolution -!============================== - - call ymap(im2, jm2, sin2, qt2, jm, sin1, qt1, 0, jord) - call xmap(iord, im2, jm, sin1, lon2, qt1, im, lon1, qm ) - -! Apply Monotonicity preserving polar filter - if( pfilter ) call plft2d(im, jm, qm, 2, jm-1, ndeg) - call polavg(qm, im, jm, 1, jm) - - deallocate ( q2 ) - deallocate ( lon1 ) - deallocate ( lon2 ) - deallocate ( sin1 ) - deallocate ( sin2 ) - - deallocate ( qt1 ) - deallocate ( qt2 ) - - return - end - - subroutine polavg(p, im, jm, jfirst, jlast) - - implicit none - - integer im, jm, jfirst, jlast - real*8 p(im,jfirst:jlast) - real*8 sum1 - integer i - - if ( jfirst == 1 ) then - sum1 = 0. - do i=1,im - sum1 = sum1 + p(i,1) - enddo - sum1 = sum1/im - - do i=1,im - p(i,1) = sum1 - enddo - endif - - if ( jlast == jm ) then - sum1 = 0. - do i=1,im - sum1 = sum1 + p(i,jm) - enddo - sum1 = sum1/im - - do i=1,im - p(i,jm) = sum1 - enddo - endif - - return - end - - subroutine setrig(im, jm, dp, dl, cosp, cose, sinp, sine) - - implicit none - - integer im, jm - integer j, jm1 - real*8 sine(jm),cosp(jm),sinp(jm),cose(jm) - real*8 dp, dl - real*8 pi, ph5 - - jm1 = jm - 1 - pi = 4.d0 * datan(1.d0) - dl = (pi+pi)/dble(im) - dp = pi/dble(jm1) - - do 10 j=2,jm - ph5 = -0.5d0*pi + (dble(j-1)-0.5d0)*(pi/dble(jm1)) -10 sine(j) = dsin(ph5) - - cosp( 1) = 0. - cosp(jm) = 0. - - do 80 j=2,jm1 -80 cosp(j) = (sine(j+1)-sine(j)) / dp - -! Define cosine at edges.. - - do 90 j=2,jm -90 cose(j) = 0.5 * (cosp(j-1) + cosp(j)) - cose(1) = cose(2) - - sinp( 1) = -1. - sinp(jm) = 1. - - do 100 j=2,jm1 -100 sinp(j) = 0.5 * (sine(j) + sine(j+1)) - - return - end - - subroutine ymap(im, jm, sin1, q1, jn, sin2, q2, iv, jord) - -! Routine to perform area preserving mapping in N-S from an arbitrary -! resolution to another. -! -! sin1 (1) = -1 must be south pole; sin1(jm+1)=1 must be N pole. -! -! sin1(1) < sin1(2) < sin1(3) < ... < sin1(jm) < sin1(jm+1) -! sin2(1) < sin2(2) < sin2(3) < ... < sin2(jn) < sin2(jn+1) -! -! Developer: S.-J. Lin -! First version: piece-wise constant mapping -! Apr 1, 2000 -! Last modified: - - implicit none - -! Input - integer im ! original E-W dimension - integer jm ! original N-S dimension - integer jn ! Target N-S dimension - integer jord - integer iv ! iv=0 scalar; iv=1: vector - real*8 sin1(jm+1) ! original southern edge of the cell - ! sin(lat1) - real*8 sin2(jn+1) ! Target cell's southern edge - real*8 q1(im,jm) ! original data at center of the cell - ! sin(lat2) -! Output - real*8 q2(im,jn) ! Mapped data at the target resolution - -! Local - integer i, j0, m, mm - integer j - -! PPM related arrays - real*8 al(im,jm) - real*8 ar(im,jm) - real*8 a6(im,jm) - real*8 dy1(jm) - - real*8 r3, r23 - parameter ( r3 = 1./3., r23 = 2./3. ) - real*8 pl, pr, qsum, esl - real*8 dy, sum - - do j=1,jm - dy1(j) = sin1(j+1) - sin1(j) - enddo - -! *********************** -! Area preserving mapping -! *********************** - -! Construct subgrid PP distribution - if ( jord == 1 ) then - - do j=1,jm - do i=1,im - a6(i,j) = 0. - ar(i,j) = q1(i,j) - al(i,j) = q1(i,j) - enddo - enddo - - else - - call ppm_lat(im, jm, q1, al, ar, a6, jord, iv) - do i=1,im -! SP - a6(i, 1) = 0. - ar(i, 1) = q1(i,1) - al(i, 1) = q1(i,1) -! NP - a6(i,jm) = 0. - ar(i,jm) = q1(i,jm) - al(i,jm) = q1(i,jm) - enddo - endif - - do 1000 i=1,im - j0 = 1 - do 555 j=1,jn - do 100 m=j0,jm -! -! locate the southern edge: sin2(i) -! - if(sin2(j) .ge. sin1(m) .and. sin2(j) .le. sin1(m+1)) then - pl = (sin2(j)-sin1(m)) / dy1(m) - if(sin2(j+1) .le. sin1(m+1)) then -! entire new cell is within the original cell - pr = (sin2(j+1)-sin1(m)) / dy1(m) - q2(i,j) = al(i,m) + 0.5*(a6(i,m)+ar(i,m)-al(i,m)) & - *(pr+pl)-a6(i,m)*r3*(pr*(pr+pl)+pl**2) - j0 = m - goto 555 - else -! South most fractional area - qsum = (sin1(m+1)-sin2(j))*(al(i,m)+0.5*(a6(i,m)+ & - ar(i,m)-al(i,m))*(1.+pl)-a6(i,m)* & - (r3*(1.+pl*(1.+pl)))) - do mm=m+1,jm -! locate the eastern edge: sin2(j+1) - if(sin2(j+1) .gt. sin1(mm+1) ) then -! Whole layer - qsum = qsum + dy1(mm)*q1(i,mm) - else -! North most fractional area - dy = sin2(j+1)-sin1(mm) - esl = dy / dy1(mm) - qsum = qsum + dy*(al(i,mm)+0.5*esl* & - (ar(i,mm)-al(i,mm)+a6(i,mm)*(1.-r23*esl))) - j0 = mm - goto 123 - endif - enddo - goto 123 - endif - endif -100 continue -123 q2(i,j) = qsum / ( sin2(j+1) - sin2(j) ) -555 continue -1000 continue - -! Final processing for poles - - if ( iv == 0 ) then - -! South pole - sum = 0. - do i=1,im - sum = sum + q2(i,1) - enddo - - sum = sum / im - do i=1,im - q2(i,1) = sum - enddo - -! North pole: - sum = 0. - do i=1,im - sum = sum + q2(i,jn) - enddo - - sum = sum / im - do i=1,im - q2(i,jn) = sum - enddo - - endif - - return - end - - subroutine ppm_lat(im, jm, q, al, ar, a6, jord, iv) - implicit none - -!INPUT - integer im, jm ! Dimensions - real*8 q(im,jm) - real*8 al(im,jm) - real*8 ar(im,jm) - real*8 a6(im,jm) - integer jord - integer iv ! iv=0 scalar - ! iv=1 vector -! Local - real*8 dm(im,jm) - real*8 r3 - parameter ( r3 = 1./3. ) - integer i, j, im2, iop, jm1 - real*8 tmp, qmax, qmin - real*8 qop - -! Compute dm: linear slope - - do j=2,jm-1 - do i=1,im - dm(i,j) = 0.25*(q(i,j+1) - q(i,j-1)) - qmax = max(q(i,j-1),q(i,j),q(i,j+1)) - q(i,j) - qmin = q(i,j) - min(q(i,j-1),q(i,j),q(i,j+1)) - dm(i,j) = sign(min(abs(dm(i,j)),qmin,qmax),dm(i,j)) - enddo - enddo - - im2 = im/2 - jm1 = jm - 1 - -!Poles: - if (iv == 1 ) then -! SP - do i=1,im - if( i .le. im2) then - qop = -q(i+im2,2) - else - qop = -q(i-im2,2) - endif - tmp = 0.25*(q(i,2) - qop) - qmax = max(q(i,2),q(i,1), qop) - q(i,1) - qmin = q(i,1) - min(q(i,2),q(i,1), qop) - dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo -! NP - do i=1,im - if( i .le. im2) then - qop = -q(i+im2,jm1) - else - qop = -q(i-im2,jm1) - endif - tmp = 0.25*(qop - q(i,jm1)) - qmax = max(qop,q(i,jm), q(i,jm1)) - q(i,jm) - qmin = q(i,jm) - min(qop,q(i,jm), q(i,jm1)) - dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - else -! -!********* -! Scalar: -!********* -! SP - do i=1,im2 - tmp = 0.25*(q(i,2)-q(i+im2,2)) - qmax = max(q(i,2),q(i,1), q(i+im2,2)) - q(i,1) - qmin = q(i,1) - min(q(i,2),q(i,1), q(i+im2,2)) - dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - - do i=im2+1,im - dm(i, 1) = - dm(i-im2, 1) - enddo -! NP - do i=1,im2 - tmp = 0.25*(q(i+im2,jm1)-q(i,jm1)) - qmax = max(q(i+im2,jm1),q(i,jm), q(i,jm1)) - q(i,jm) - qmin = q(i,jm) - min(q(i+im2,jm1),q(i,jm), q(i,jm1)) - dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - - do i=im2+1,im - dm(i,jm) = - dm(i-im2,jm) - enddo - endif - - do j=2,jm - do i=1,im - al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j)) - enddo - enddo - - do j=1,jm-1 - do i=1,im - ar(i,j) = al(i,j+1) - enddo - enddo - - do j=2,jm-1 - do i=1,im - a6(i,j) = 3.*(q(i,j)+q(i,j) - (al(i,j)+ar(i,j))) - enddo - - call lmppm(dm(1,j), a6(1,j), ar(1,j), & - al(1,j), q(1,j), im, jord-3) - enddo - - return - end - - subroutine xmap(iord, im, jm, sin1, lon1, q1, in, lon2, q2) - -! Routine to perform area preserving mapping in E-W from an arbitrary -! resolution to another. -! Periodic domain will be assumed, i.e., the eastern wall bounding cell -! im is lon1(im+1) = lon1(1); Note the equal sign is true geographysically. -! -! lon1(1) < lon1(2) < lon1(3) < ... < lon1(im) < lon1(im+1) -! lon2(1) < lon2(2) < lon2(3) < ... < lon2(in) < lon2(in+1) -! -! Developer: S.-J. Lin -! First version: piece-wise constant mapping -! Apr 1, 2000 -! Last modified: - - implicit none - -! Input - integer iord - integer im ! original E-W dimension - integer in ! Target E-W dimension - integer jm ! original N-S dimension - real*8 lon1(im+1) ! original western edge of the cell - real*8 sin1(jm+1) - real*8 q1(im,jm) ! original data at center of the cell - real*8 lon2(in+1) ! Target cell's western edge - -! Output - real*8 q2(in,jm) ! Mapped data at the target resolution - -! Local - integer i1, i2 - integer i, i0, m, mm - integer j - integer ird - -! PPM related arrays - real*8 qtmp(-im:im+im) - real*8 al(-im:im+im) - real*8 ar(-im:im+im) - real*8 a6(-im:im+im) - real*8 x1(-im:im+im+1) - real*8 dx1(-im:im+im) - real*8 r3, r23 - parameter ( r3 = 1./3., r23 = 2./3. ) - real*8 pl, pr, qsum, esl - real*8 dx - logical found - - do i=1,im+1 - x1(i) = lon1(i) - enddo - - do i=1,im - dx1(i) = x1(i+1) - x1(i) - enddo - -! check to see if ghosting is necessary - -!************** -! Western edge: -!************** - found = .false. - i1 = 1 - do while ( .not. found ) - if( lon2(1) .ge. x1(i1) ) then - found = .true. - else - i1 = i1 - 1 - if (i1 .lt. -im) then - write(6,*) 'failed in xmap' - stop - else - x1(i1) = x1(i1+1) - dx1(im+i1) - dx1(i1) = dx1(im+i1) - endif - endif - enddo - -!************** -! Eastern edge: -!************** - found = .false. - i2 = im+1 - do while ( .not. found ) - if( lon2(in+1) .le. x1(i2) ) then - found = .true. - else - i2 = i2 + 1 - if (i2 .gt. 2*im) then - write(6,*) 'failed in xmap' - stop - else - dx1(i2-1) = dx1(i2-1-im) - x1(i2) = x1(i2-1) + dx1(i2-1) - endif - endif - enddo - - do 1000 j=1,jm - -! *********************** -! Area preserving mapping -! *********************** - -! Construct subgrid PP distribution - if ( abs(sin1(j)+sin1(j+1)) > 1.5 ) then - ird = 3 - elseif ( abs(sin1(j)+sin1(j+1)) < 1.0 ) then - ird = 8 - else - ird = iord - endif - - if ( iord == 1 ) then - do i=1,im - qtmp(i) = q1(i,j) - al(i) = q1(i,j) - ar(i) = q1(i,j) - a6(i) = 0. - enddo - qtmp(0 ) = q1(im,j) - qtmp(im+1) = q1(1, j) - else - call ppm_cycle(im, q1(1,j), al(1), ar(1), a6(1), qtmp, ird) - endif - -! check to see if ghosting is necessary - -! Western edge - if ( i1 .le. 0 ) then - do i=i1,0 - qtmp(i) = qtmp(im+i) - al(i) = al(im+i) - ar(i) = ar(im+i) - a6(i) = a6(im+i) - enddo - endif - -! Eastern edge: - if ( i2 .gt. im+1 ) then - do i=im+1,i2-1 - qtmp(i) = qtmp(i-im) - al(i) = al(i-im) - ar(i) = ar(i-im) - a6(i) = a6(i-im) - enddo - endif - - i0 = i1 - - do 555 i=1,in - do 100 m=i0,i2-1 -! -! locate the western edge: lon2(i) -! - if(lon2(i) .ge. x1(m) .and. lon2(i) .le. x1(m+1)) then - pl = (lon2(i)-x1(m)) / dx1(m) - if(lon2(i+1) .le. x1(m+1)) then -! entire new grid is within the original grid - pr = (lon2(i+1)-x1(m)) / dx1(m) - q2(i,j) = al(m) + 0.5*(a6(m)+ar(m)-al(m)) & - *(pr+pl)-a6(m)*r3*(pr*(pr+pl)+pl**2) - i0 = m - goto 555 - else -! Left most fractional area - qsum = (x1(m+1)-lon2(i))*(al(m)+0.5*(a6(m)+ & - ar(m)-al(m))*(1.+pl)-a6(m)* & - (r3*(1.+pl*(1.+pl)))) - do mm=m+1,i2-1 -! locate the eastern edge: lon2(i+1) - if(lon2(i+1) .gt. x1(mm+1) ) then -! Whole layer - qsum = qsum + dx1(mm)*qtmp(mm) - else -! Right most fractional area - dx = lon2(i+1)-x1(mm) - esl = dx / dx1(mm) - qsum = qsum + dx*(al(mm)+0.5*esl* & - (ar(mm)-al(mm)+a6(mm)*(1.-r23*esl))) - i0 = mm - goto 123 - endif - enddo - goto 123 - endif - endif -100 continue -123 q2(i,j) = qsum / ( lon2(i+1) - lon2(i) ) -555 continue -1000 continue - - return - end - - subroutine ppm_cycle(im, q, al, ar, a6, p, iord) - implicit none - - real*8 r3 - parameter ( r3 = 1./3. ) - -! Input - integer im, iord - real*8 q(1) -! Output - real*8 al(1) - real*8 ar(1) - real*8 a6(1) - real*8 p(-im:im+im) - -! local - real*8 dm(0:im) - integer i, lmt - real*8 tmp, qmax, qmin - - p(0) = q(im) - do i=1,im - p(i) = q(i) - enddo - p(im+1) = q(1) - -! 2nd order slope - do i=1,im - tmp = 0.25*(p(i+1) - p(i-1)) - qmax = max(p(i-1), p(i), p(i+1)) - p(i) - qmin = p(i) - min(p(i-1), p(i), p(i+1)) - dm(i) = sign(min(abs(tmp),qmax,qmin), tmp) - enddo - dm(0) = dm(im) - - do i=1,im - al(i) = 0.5*(p(i-1)+p(i)) + (dm(i-1) - dm(i))*r3 - enddo - - do i=1,im-1 - ar(i) = al(i+1) - enddo - ar(im) = al(1) - - do i=1,im - a6(i) = 3.*(p(i)+p(i) - (al(i)+ar(i))) - enddo - - if(iord <= 6) then - lmt = iord - 3 - if(lmt <= 2) call lmppm(dm(1),a6(1),ar(1),al(1),p(1),im,lmt) - else - call huynh(im, ar(1), al(1), p(1), a6(1), dm(1)) - call lmppm(dm(1),a6(1),ar(1),al(1),p(1),im,2) - endif - - return - end - - subroutine lmppm(dm, a6, ar, al, p, im, lmt) - implicit none - real*8 r12 - parameter ( r12 = 1./12. ) - - integer im, lmt - integer i - real*8 a6(im),ar(im),al(im),p(im),dm(im) - real*8 da1, da2, fmin, a6da - -! LMT = 0: full monotonicity -! LMT = 1: semi-monotonic constraint (no undershoot) -! LMT = 2: positive-definite constraint - - if(lmt.eq.0) then - -! Full constraint - do 100 i=1,im - if(dm(i) .eq. 0.) then - ar(i) = p(i) - al(i) = p(i) - a6(i) = 0. - else - da1 = ar(i) - al(i) - da2 = da1**2 - a6da = a6(i)*da1 - if(a6da .lt. -da2) then - a6(i) = 3.*(al(i)-p(i)) - ar(i) = al(i) - a6(i) - elseif(a6da .gt. da2) then - a6(i) = 3.*(ar(i)-p(i)) - al(i) = ar(i) - a6(i) - endif - endif -100 continue - - elseif(lmt == 1) then -! Semi-monotonic constraint - do 150 i=1,im - if(abs(ar(i)-al(i)) .ge. -a6(i)) go to 150 - if(p(i).lt.ar(i) .and. p(i).lt.al(i)) then - ar(i) = p(i) - al(i) = p(i) - a6(i) = 0. - elseif(ar(i) .gt. al(i)) then - a6(i) = 3.*(al(i)-p(i)) - ar(i) = al(i) - a6(i) - else - a6(i) = 3.*(ar(i)-p(i)) - al(i) = ar(i) - a6(i) - endif -150 continue - elseif(lmt == 2) then -! Positive definite constraint - do 250 i=1,im - if(abs(ar(i)-al(i)) >= -a6(i)) go to 250 - fmin = p(i) + 0.25*(ar(i)-al(i))**2/a6(i) + a6(i)*r12 - if(fmin >= 0.) go to 250 - if(p(i).lt.ar(i) .and. p(i).lt.al(i)) then - ar(i) = p(i) - al(i) = p(i) - a6(i) = 0. - elseif(ar(i) .gt. al(i)) then - a6(i) = 3.*(al(i)-p(i)) - ar(i) = al(i) - a6(i) - else - a6(i) = 3.*(ar(i)-p(i)) - al(i) = ar(i) - a6(i) - endif -250 continue - endif - return - end - - subroutine huynh(im, ar, al, p, d2, d1) - -! Enforce Huynh's 2nd constraint in 1D periodic domain - - implicit none - integer im, i - real*8 ar(im) - real*8 al(im) - real*8 p(im) - real*8 d2(im) - real*8 d1(im) - -! Local scalars: - real*8 pmp - real*8 lac - real*8 pmin - real*8 pmax - -! Compute d1 and d2 - d1(1) = p(1) - p(im) - do i=2,im - d1(i) = p(i) - p(i-1) - enddo - - do i=1,im-1 - d2(i) = d1(i+1) - d1(i) - enddo - d2(im) = d1(1) - d1(im) - -! Constraint for AR -! i = 1 - pmp = p(1) + 2.0 * d1(1) - lac = p(1) + 0.5 * (d1(1)+d2(im)) + d2(im) - pmin = min(p(1), pmp, lac) - pmax = max(p(1), pmp, lac) - ar(1) = min(pmax, max(ar(1), pmin)) - - do i=2, im - pmp = p(i) + 2.0*d1(i) - lac = p(i) + 0.5*(d1(i)+d2(i-1)) + d2(i-1) - pmin = min(p(i), pmp, lac) - pmax = max(p(i), pmp, lac) - ar(i) = min(pmax, max(ar(i), pmin)) - enddo - -! Constraint for AL - do i=1, im-1 - pmp = p(i) - 2.0*d1(i+1) - lac = p(i) + 0.5*(d2(i+1)-d1(i+1)) + d2(i+1) - pmin = min(p(i), pmp, lac) - pmax = max(p(i), pmp, lac) - al(i) = min(pmax, max(al(i), pmin)) - enddo - -! i=im - i = im - pmp = p(im) - 2.0*d1(1) - lac = p(im) + 0.5*(d2(1)-d1(1)) + d2(1) - pmin = min(p(im), pmp, lac) - pmax = max(p(im), pmp, lac) - al(im) = min(pmax, max(al(im), pmin)) - -! compute A6 (d2) - do i=1, im - d2(i) = 3.*(p(i)+p(i) - (al(i)+ar(i))) - enddo - return - end - - subroutine plft2d(im, jm, p, JS, JN, ndeg) -! -! This is a weak LOCAL polar filter. -! Developer: Shian-Jiann Lin - - implicit none - - integer im - integer jm - integer js, jn, ndeg - real*8 p(im,jm) - - integer i, j, n, ideg, jj, jc - real*8 cosp(jm),cose(jm) - real*8 a(0:im/2+1) - - real*8 sine(jm),sinp(jm) - real*8, allocatable, save :: se(:), sc(:) - - real*8 pi, dp, dl, e0, ycrit, coszc, smax, rn, rn2, esl, tmp - - data IDEG /0/ - - if(IDEG .ne. ndeg) then - IDEG = ndeg -! (e0 = 2.6) - e0 = 0.5 * sqrt(27.) - PI = 4. * ATAN(1.) - - allocate( sc(jm), se(jm)) - - call setrig(im, jm, dp, dl, cosp, cose, sinp, sine) - - ycrit = IDEG*PI/180. - coszc = cos(ycrit) - - smax = (jm-1)/2 - write(6,*) 'Critical latitude in local pft = ',ndeg - - a(0) = 1. - do n=1,im/2+1 - rn = n - rn2 = 2*n - a(n) = sqrt(rn2+1.) * ((rn2+1.)/rn2)**rn - enddo - - do j=2,jm-1 - sc(j) = coszc / cosp(j) - - IF(sc(j) > 1. .and. sc(j) <= 1.5 ) THEN - esl = 1./ sc(j) - sc(j) = 1. + (1.-esl) / (1.+esl) - ELSEIF(sc(j) > 1.5 .and. sc(j) <= e0 ) THEN - esl = 1./ sc(j) - sc(j) = 1. + 2./ (27.*esl**2 - 2.) - ELSEIF(sc(j) > e0) THEN -! Search - do jj=1,im/2 - if(sc(j) <= a(jj)) then - jc = jj -! write(*,*) 'jc=', jc - goto 111 - endif - enddo - jc = im/2 + 1 -111 continue - - tmp = ((sc(j) - a(jc-1))/(a(jc) - a(jc-1)))**0.25 - sc(j) = jc + min(1.d0, tmp) -! sc(j) = min(smax,sc(j)) - ENDIF - enddo -! ==================================================== - do j=2,jm - se(j) = coszc / cose(j) - IF(se(j) > 1. .and. se(j) <= 1.5 ) THEN - esl = 1./ se(j) - se(j) = 1. + (1.-esl) / (1.+esl) - ELSEIF(se(j) > 1.5 .and. se(j) <= e0 ) THEN - esl = 1./ se(j) - se(j) = 1. + 2./ (27.*esl**2 - 2.) - ELSEIF(se(j) > e0) THEN -! Search - do jj=1,im/2 - if(se(j) <= a(jj)) then - jc = jj - goto 222 - endif - enddo - - jc = im/2 + 1 -222 continue - tmp = ((se(j) - a(jc-1))/(a(jc) - a(jc-1)))**0.25 - se(j) = jc + min(1.d0, tmp) -! se(j) = min(smax,se(j)) - ENDIF - enddo - - do i=1,im - se( 2) = sc(2) - se(jm) = sc(jm-1) - enddo - - do j=2,jm-1 -! write(*,*) j,sc(j) - enddo - ENDIF - - if( JN == (jm-1) ) then -! Cell-centered variables - call lpft(im, jm, p, 2, jm-1, Sc) - else -! Cell-edge variables - call lpft(im, jm, p, 2, jm, Se) - endif - return - end - - - subroutine lpft(im, jm, p, j1, j2, s) - implicit none - - integer im, jm, j1, j2 - real*8 p(im,jm) - real*8 s(jm) - -! Local - integer i, j, n, nt - - real*8 ptmp(0:im+1) - real*8 q(0:im+1) - real*8 frac, rsc, bt - - do 2500 j=j1,j2 - if(s(j) > 1.02) then - - NT = INT(S(j)) - frac = S(j) - NT - NT = NT-1 - - rsc = 1. / (1.+frac) - bt = 0.5 * frac - - do i=1,im - ptmp(i) = p(i,j) - enddo - - ptmp(0) = p(im,j) - ptmp(im+1) = p(1 ,j) - - if( NT < 1 ) then - do i=1,im - p(i,j) = rsc * (ptmp(i) + bt*(ptmp(i-1)+ptmp(i+1))) - enddo - else - do i=1,im - q(i) = rsc * (ptmp(i) + bt*(ptmp(i-1)+ptmp(i+1))) - enddo - - do 500 N=1,NT - q(0) = q(im) - do i=1,im - ptmp(i) = q(i) + q(i-1) - enddo - ptmp(im+1) = ptmp(1) - - if ( n == nt ) then - do i=1,im - p(i,j) = 0.25*(ptmp(i) + ptmp(i+1)) - enddo - else - do i=1,im - q(i) = 0.25*(ptmp(i) + ptmp(i+1)) - enddo - endif -500 continue - endif - endif -2500 continue - - return - end diff --git a/tools/definesurf/map_i.f90 b/tools/definesurf/map_i.f90 deleted file mode 100644 index d73e02e7db..0000000000 --- a/tools/definesurf/map_i.f90 +++ /dev/null @@ -1,136 +0,0 @@ -subroutine map_i (nlon_i , nlat_i , numlon_i, lon_i , lat_i, & - nlon_o , nlat_o , numlon_o, lon_o , lat_o, & - mxovr_i2o, iovr_i2o, jovr_i2o, wovr_i2o) - - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - -! ------------------------ code history --------------------------- -! source file: map_i.F -! purpose: driver for area averaging initialization -! date last revised: July 2000 -! author: Mariana Vertenstein -! ----------------------------------------------------------------- - -! ------------------------ notes ---------------------------------- -! o get indices and weights for area-averaging: -! -! from input surface grid to output model grid -! -! o input surface and output model grids can be any resolution BUT: -! -! both grids must be oriented south to north, i.e., cell(lat+1) -! must be north of cell(lat). the southern edge of the first row -! must be -90 (south pole) and the northern edge of the last row -! must be +90 (north pole) -! -! both grids must be oriented eastwards, i.e., cell(lon+1) must be -! east of cell(lon). but the two grids do not have to start at the -! same longitude, i.e., one grid can start at dateline and go east; -! the other grid can start at greenwich and go east. longitudes for -! the western edge of the cells must increase continuously and span -! 360 degrees. examples -! dateline : -180 to 180 (- longitudes west of greenwich) -! greenwich : 0 to 360 -! greenwich (centered): -dx/2 to -dx/2 + 360 (- longitudes west of greenwich) -! -! o field values fld_i on an input grid with dimensions nlon_i and nlat_i => -! field values fld_o on an output grid with dimensions nlon_o and nlat_o as -! -! fld_o(io,jo) = -! fld_i(i_ovr(io,jo, 1 ),j_ovr(io,jo, 1 )) * w_ovr(io,jo, 1 ) + -! fld_i(i_ovr(io,jo,mxovr_i),j_ovr(io,jo,mxovr_i)) * w_ovr(io,jo,mxovr_i) -! -! o error checks: -! overlap weights of input cells sum to 1 for each output cell -! global sums of dummy fields are conserved for input => model area-averaging -! ----------------------------------------------------------------- - -! ------------------- arguments ----------------------------------- - integer , intent(in) :: nlon_i !input grid max number of longitude points - integer , intent(in) :: nlat_i !input grid number of latitude points - integer , intent(in) :: numlon_i(nlat_i) !input grid number of longitude points at each lat - real(r8), intent(in) :: lon_i(nlon_i+1,nlat_i) !input grid cell longitude, west edge (degrees) - real(r8), intent(in) :: lat_i(nlat_i+1) !input grid cell latitude, south edge (degrees) - integer , intent(in) :: nlon_o !model grid max number of longitude points - integer , intent(in) :: nlat_o !model grid number of latitude points - integer , intent(in) :: numlon_o(nlat_o) !model grid number of longitude points at each lat - real(r8), intent(in) :: lon_o(nlon_o+1,nlat_o) !model grid cell longitude, west edge (degrees) - real(r8), intent(in) :: lat_o(nlat_o+1) !model grid cell latitude, south edge (degrees) - integer , intent(in) :: mxovr_i2o !max number of input cells that overlap model cell - integer , intent(out):: iovr_i2o(nlon_o,nlat_o,mxovr_i2o) !lon index of overlap input cell - integer , intent(out):: jovr_i2o(nlon_o,nlat_o,mxovr_i2o) !lat index of overlap input cell - real(r8), intent(out):: wovr_i2o(nlon_o,nlat_o,mxovr_i2o) !weight of overlap input cell -! ----------------------------------------------------------------- -! -! ------------------- local variables ----------------------------- -! - real(r8) fld_i(nlon_i,nlat_i) !dummy input grid field - real(r8) fld_o(nlon_o,nlat_o) !dummy model grid field - real(r8) area_i(nlon_i,nlat_i) !input grid cell area - real(r8) area_o(nlon_o,nlat_o) !model grid cell area - real(r8) re !radius of earth - real(r8) sum_fldo !global sum of dummy model field - real(r8) sum_fldi !global sum of dummy input field - integer io,ii !model and input longitude loop indices - integer jo,ji !model and input latitude loop indices - real(r8), parameter :: relerr = 0.000001 !relative error for error checks -! ----------------------------------------------------------------- - -! ----------------------------------------------------------------- -! get cell areas -! ----------------------------------------------------------------- - - call cell_area (nlat_i, nlon_i, numlon_i, lon_i, lat_i, re, area_i) - - call cell_area (nlat_o, nlon_o, numlon_o, lon_o, lat_o, re, area_o) - -! ----------------------------------------------------------------- -! get indices and weights for mapping from input grid to model grid -! ----------------------------------------------------------------- - - call ao_i (nlon_i , nlat_i , numlon_i, lon_i , lat_i , & - nlon_o , nlat_o , numlon_o, lon_o , lat_o , & - mxovr_i2o, iovr_i2o , jovr_i2o, wovr_i2o , re , & - area_o , relerr ) - -! ----------------------------------------------------------------- -! error check: global sum fld_o = global sum fld_i -! ----------------------------------------------------------------- -! -! make dummy input field and sum globally -! - sum_fldi = 0. - do ji = 1, nlat_i - do ii = 1, numlon_i(ji) - fld_i(ii,ji) = (ji-1)*nlon_i + ii - sum_fldi = sum_fldi + area_i(ii,ji)*fld_i(ii,ji) - end do - end do -! -! area-average model field from input field -! - call area_ave (nlat_i , nlon_i , numlon_i ,fld_i , & - nlat_o , nlon_o , numlon_o ,fld_o , & - iovr_i2o , jovr_i2o , wovr_i2o , mxovr_i2o) -! -! global sum of model field -! - sum_fldo = 0. - do jo = 1, nlat_o - do io = 1, numlon_o(jo) - sum_fldo = sum_fldo + area_o(io,jo)*fld_o(io,jo) - end do - end do -! -! check for conservation -! - if ( abs(sum_fldo/sum_fldi-1.) > relerr ) then - write (6,*) 'map_i error srf => model: srf field not conserved' - write (6,'(a23,e20.10)') 'global sum model field = ',sum_fldo - write (6,'(a23,e20.10)') 'global sum srf field = ',sum_fldi - call endrun - end if - - return -end subroutine map_i diff --git a/tools/definesurf/max_ovr.f90 b/tools/definesurf/max_ovr.f90 deleted file mode 100644 index 46b01fdc38..0000000000 --- a/tools/definesurf/max_ovr.f90 +++ /dev/null @@ -1,93 +0,0 @@ -subroutine max_ovr (nlon_i, nlat_i, numlon_i, nlon_o, nlat_o, numlon_o, & - lon_i , lat_i , lon_o , lat_o , novr_max) - - use shr_kind_mod, only: r8 => shr_kind_r8 - -! ----------------------------------------------------------------- - implicit none -! ------------------------ code history --------------------------- -! source file: max_ovr -! purpose: determine maximum number of overlapping cells -! input and output grids -! date last revised: March 1997 -! author: Mariana Vertenstein -! standardized: -! reviewed: -! ----------------------------------------------------------------- - -! ------------------- input variables ----------------------------- - integer, intent(in) :: nlon_i !number of input longitude points - integer, intent(in) :: nlat_i !number of input latitude points - integer, intent(in) :: numlon_i(nlat_i) !number of longitude points for each input grid cell latitude - integer, intent(in) :: nlon_o !number of output longitude points - integer, intent(in) :: nlat_o !number of output latitude points - integer, intent(in) :: numlon_o(nlat_o) !number of longitude points for each output grid cell latitude - real(r8), intent(in) :: lon_i(nlon_i+1,nlat_i) !input grid cell longitude, western edge - real(r8), intent(in) :: lat_i(nlat_i+1) !input grid cell latitude, southern edge - real(r8), intent(in) :: lon_o(nlon_o+1,nlat_o) !output grid cell longitude, western edge - real(r8), intent(in) :: lat_o(nlat_o+1) !output grid cell latitude , southern edge - integer , intent(out):: novr_max !maximum number of overlapping input cells -! ----------------------------------------------------------------- - -! ------------------- local variables ----------------------------- - integer novr !number of overlapping input cells - integer io,ii !output and input grids longitude loop index - integer jo,ji !output and input grids latitude loop index -! ----------------------------------------------------------------- - - -! ----------------------------------------------------------------- -! for each output grid cell: find overlapping input grid cell and area of -! input grid cell that overlaps with output grid cell. cells overlap if: -! -! southern edge of input grid < northern edge of output grid AND -! northern edge of input grid > southern edge of output grid -! -! western edge of input grid < eastern edge of output grid AND -! eastern edge of input grid > western edge of output grid -! -! lon_o(io,jo) lon_o(io+1,jo) -! -! | | -! --------------------- lat_o(jo+1) -! | | -! | | -! xxxxxxxxxxxxxxx lat_i(ji+1) | -! x | x | -! x input | x output | -! x cell | x cell | -! x ii,ji | x io,jo | -! x | x | -! x ----x---------------- lat_o(jo ) -! x x -! xxxxxxxxxxxxxxx lat_i(ji ) -! x x -! lon_i(ii,ji) lon_i(ii+1,ji) -! ----------------------------------------------------------------- - -! -! determine maximum number of overlapping cells -! loop through all input grid cells to find overlap with output grid. -! code does not vectorize but is only called during initialization. -! - novr_max = 0 - do jo = 1, nlat_o - do io = 1, numlon_o(jo) - novr = 0 - do ji = 1, nlat_i - if (lat_i(ji ).lt.lat_o(jo+1) .and. & - lat_i(ji+1).gt.lat_o(jo )) then !lat ok - do ii = 1, numlon_i(ji) - if (lon_i(ii ,ji).lt.lon_o(io+1,jo) .and. & - lon_i(ii+1,ji).gt.lon_o(io ,jo)) then !lon okay - novr = novr + 1 ! increment number of ovrlap cells for io,jo - end if - end do - end if - end do - if (novr .gt. novr_max) novr_max = novr - end do - end do - - return -end subroutine max_ovr diff --git a/tools/definesurf/sghphis.f90 b/tools/definesurf/sghphis.f90 deleted file mode 100644 index 39a694aa84..0000000000 --- a/tools/definesurf/sghphis.f90 +++ /dev/null @@ -1,340 +0,0 @@ -subroutine sghphis (plon, plat, numlons, mlatcnts, mloncnts, & - topofile, verbose, sgh, sgh30, have_sgh30, phis, fland ) - -!----------------------------------------------------------------------- -! -! Read high resolution topo dataset and calculate values of phis and sgh -! for the model resolution this model -! -!----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - include 'netcdf.inc' -! -!----------------------------------------------------------------------- -! -! parameters -! - integer , parameter :: ntopolon = 2160 - integer , parameter :: ntopolat = 1080 - integer , parameter :: n2x2lon = 180 - integer , parameter :: n2x2lat = 90 - integer , parameter :: n3x3lon = 120 - integer , parameter :: n3x3lat = 60 - real(r8), parameter :: r8_360 = 360. ! For argument compatibility to mod -! -! arguments -! - integer , intent(in) :: plon ! maximum number of model longitudes - integer , intent(in) :: plat ! number of model latitudes - integer , intent(in) :: numlons(plat) ! number of model longitudes per latitude - real(r8), intent(in) :: mlatcnts(plat) ! model cell center latitudes - real(r8), intent(in) :: mloncnts(plon,plat) ! model cell ceneter longitudes - logical , intent(in) :: verbose ! true => verbose output - character(len=*), intent(in) :: topofile ! high resolution topo file - real(r8), intent(out):: phis(plon,plat) ! model geopotention height - real(r8), intent(out):: sgh(plon,plat) ! model standard dev of geopotential height above 10min - real(r8), intent(out):: sgh30(plon,plat) ! model standard dev of geopotential height from 30s to 10m - logical , intent(out):: have_sgh30 ! true => variance is on topofile, sgh30 will be output - real(r8), intent(out):: fland(plon,plat) ! model fractional land -! -! Local workspace : note that anything with plon or plat in its dimension is dynamic -! - real(r8) wt ! weight for area averaging - real(r8) dx,dy ! increments for definition of intermed grid - -! high resolution topo grid - - integer lonid_topo, latid_topo ! input topo file vars - integer htopoid,ftopoid,ret,varianceid ! input topo file vars - real(r8) tloncnts(ntopolon) ! topo cell center lon boundaries - real(r8) tlatcnts(ntopolat) ! topo cell center lat boundaries - real(r8) tlons(ntopolon+1,ntopolat) ! topo cell W lon boundaries - real(r8) tlats(ntopolat+1) ! topo cell N lat boundaries - real(r8) ftopo(ntopolon,ntopolat) ! Land fraction array - real(r8) htopo(ntopolon,ntopolat) ! Topographic heights - real(r8) variance(ntopolon,ntopolat) ! Variance of elev at 30sec - -! intermediate grid - - real(r8) lons3x3(n3x3lon+1,n3x3lat) ! list of topo cell W lon boundaries - real(r8) lats3x3(n3x3lat+1) ! list of topo cell N lat boundaries - integer num3x3lons(n3x3lat) ! number if longitudes per latitude - real(r8) mnhgt3x3(n3x3lon,n3x3lat) ! intermediate topo height - real(r8) varhgt3x3(n3x3lon,n3x3lat) ! intermediate topovariance - -! model grid - - real(r8) mlons(plon+1,plat) ! model cell W lon boundaries - real(r8) mlats(plat+1) ! model cell N lat boundaries - real(r8) mnhgt(plon,plat) ! model topographic height - real(r8) varhgt(plon,plat) ! model topographic variance - real(r8) summn, sumvar ! use only for pole point calculations - -! other vars - - real(r8) xmax ! temporary variable - real(r8), parameter :: eps = 1.e-6 ! eps criterion for pole point - integer imax, jmax ! indices - integer i,j,ii,ji,io,jo,n ! indices - integer ncid_topo ! topographic netcdf id - integer ioe - integer mxovr ! max number of fine grid points used in area calculation of model grid point -! -! Space needed in 3 dimensions to store the initial data. This space is -! required because the input data file does not have a predetermined -! ordering of the latitude records. A specific order is imposed in the -! transforms so that the results will be reproducible. -! -! Dynamic -! - integer , allocatable :: iovr(:,:,:) ! lon index of overlap input cell - integer , allocatable :: jovr(:,:,:) ! lat index of overlap input cell - real(r8), allocatable :: wovr(:,:,:) ! weight of overlap input cell -! -!----------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -! Read in navy topo cell locations and determine cell edges (Uniform grid) -!---------------------------------------------------------------------------- -! - ret = nf_open (topofile, nf_nowrite, ncid_topo) - if (ret == nf_noerr) then - if (verbose) write(6,*)'Successfully opened netcdf topofile ',trim(topofile) - ret = nf_inq_varid (ncid_topo, 'variance', varianceid) - if (ret == NF_NOERR) then - if (verbose) write(6,*)'Found a new style topofile.' - call wrap_get_var8 (ncid_topo, varianceid, variance ) - call wrap_inq_varid (ncid_topo, 'landfract', ftopoid ) - have_sgh30 = .true. - else - if (verbose) write(6,*)'Found an old style topofile.' - call wrap_inq_varid (ncid_topo, 'ftopo', ftopoid ) - have_sgh30 = .false. - end if - call wrap_get_var8 (ncid_topo, ftopoid, ftopo) - call wrap_inq_varid (ncid_topo, 'htopo', htopoid ) - call wrap_get_var8 (ncid_topo, htopoid, htopo) - else - write(6,*)'cannot open topo file successfully' - call endrun - endif - - call wrap_inq_varid (ncid_topo, 'lon', lonid_topo) - call wrap_inq_varid (ncid_topo, 'lat', latid_topo) - - call wrap_get_var8 (ncid_topo, latid_topo, tlatcnts) - call wrap_get_var8 (ncid_topo, lonid_topo, tloncnts) - ret = nf_close (ncid_topo) - - tloncnts(:) = mod(tloncnts(:)+r8_360,r8_360) - - tlats(:) = 1.e36 - tlats(1) = -90. ! south pole - do j = 2, ntopolat - tlats(j) = (tlatcnts(j-1) + tlatcnts(j)) / 2. ! southern edges - end do - tlats(ntopolat+1) = 90. ! north pole - - tlons(:,:) = 1.e36 - do j = 1,ntopolat - dx = 360./ntopolon - tlons(1,j) = tloncnts(1) - dx/2. - do i = 2, ntopolon - tlons(i,j) = tloncnts(i) - dx/2. - end do - tlons(ntopolon+1,j) = tloncnts(ntopolon) + dx/2. - end do -! -!---------------------------------------------------------------------------- -! Determine model cell edges -!---------------------------------------------------------------------------- -! - mlats(:) = 1.e36 - mlats(1) = -90. ! south pole - do j = 2,plat - mlats(j) = (mlatcnts(j-1) + mlatcnts(j)) / 2. ! southern edges - end do - mlats(plat+1) = 90. ! north pole - - do j = 1,plat - dx = 360./(numlons(j)) - do i = 1,plon+1 - mlons(i,j) = -dx/2. + (i-1)*dx - end do - end do - -! -!---------------------------------------------------------------------------- -! Calculate fractional land -!---------------------------------------------------------------------------- -! - call binf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,ftopo, & - mlons ,mlats ,plon ,plat ,fland) -! -!---------------------------------------------------------------------------- -! Calculate standard deviation of elevation from 30sec to 10min -!---------------------------------------------------------------------------- - - if (have_sgh30) then - call binf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,variance, & - mlons ,mlats ,plon ,plat ,sgh30) - else - sgh30 = -1 - endif -!------------------------------------------------------------------------- -! Calculate determine mean and variance of topographic height, plon >=128 -!------------------------------------------------------------------------- -! - if (plon >= 128) then - call binf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,htopo, & - mlons ,mlats ,plon ,plat ,mnhgt) - - call varf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,htopo , & - mlons ,mlats ,plon ,plat ,mnhgt , & - varhgt ) - end if - -!------------------------------------------------------------------------- -! Calculate determine mean and variance of topographic height, plon < 128 -!------------------------------------------------------------------------- - - if (plon < 128) then -! -! bin to uniform 3x3 deg grid then area avg to output grid -! get 3x3 cell boundaries for binning routine -! - dy = 180./n3x3lat - do j = 1, n3x3lat+1 - lats3x3(j) = -90.0 + (j-1)*dy - end do - - num3x3lons(:) = n3x3lon - do j = 1,n3x3lat - dx = 360./(num3x3lons(j)) - do i = 1, num3x3lons(j)+1 - lons3x3(i,j) = 0. + (i-1)*dx - end do - end do -! -! bin mean height to intermed grid -! - call binf2c (tloncnts, tlatcnts, ntopolon, ntopolat, htopo, & - lons3x3 , lats3x3 , n3x3lon , n3x3lat , mnhgt3x3) -! -! get variation of topography mean height over the intermed grid -! - call varf2c (tloncnts, tlatcnts, ntopolon, ntopolat, htopo , & - lons3x3 , lats3x3 , n3x3lon , n3x3lat , mnhgt3x3, & - varhgt3x3 ) -! -! get maximum number of 3x3 cells which will to be used in area average -! for each model cell -! - call max_ovr (n3x3lon, n3x3lat, num3x3lons, plon , plat, numlons, & - lons3x3, lats3x3, mlons , mlats , mxovr ) -! -! do area average from intermediate regular grid to gauss grid -! get memory for pointer based arrays -! - allocate(iovr(plon,plat,mxovr)) - allocate(jovr(plon,plat,mxovr)) - allocate(wovr(plon,plat,mxovr)) - - call map_i (n3x3lon, n3x3lat, num3x3lons, lons3x3, lats3x3, & - plon , plat , numlons , mlons , mlats , & - mxovr , iovr , jovr , wovr ) - - do jo = 1, plat - do io = 1, numlons(jo) - mnhgt(io,jo) = 0. - varhgt(io,jo) = 0. - do n = 1, mxovr ! overlap cell index - ii = iovr(io,jo,n) ! lon index (input grid) of overlap cell - ji = jovr(io,jo,n) ! lat index (input grid) of overlap cell - wt = wovr(io,jo,n) ! overlap weight - mnhgt(io,jo) = mnhgt(io,jo) + mnhgt3x3(ii,ji) * wt - varhgt(io,jo) = varhgt(io,jo) + varhgt3x3(ii,ji) * wt - end do - end do - end do - -! If model grid contains pole points, then overwrite above values of phis and sgh at the -! poles with average of values of nearest 2x2 band - this is a fair approximation and -! is done so that above mapping routines do not have to be rewritten to correctly evaulte -! the area average of the pole points - - if (mlatcnts(1)-eps < -90.0 .and. mlatcnts(plat)+eps > 90.0) then - write(6,*)' determining sgh and phis at poles' - summn = 0 - sumvar = 0 - do io = 1,numlons(2) - summn = summn + mnhgt(io,2) - sumvar = sumvar + varhgt(io,2) - end do - do io = 1,numlons(1) - mnhgt(io,1) = summn/numlons(2) - varhgt(io,1) = sumvar/numlons(2) - end do - summn = 0 - sumvar = 0 - do io = 1,numlons(plat-1) - summn = summn + mnhgt(io,plat-1) - sumvar = sumvar + varhgt(io,plat-1) - end do - do io = 1,numlons(plat) - mnhgt(io,plat) = summn/numlons(plat-1) - varhgt(io,plat) = sumvar/numlons(plat-1) - end do - endif - - deallocate(iovr) - deallocate(jovr) - deallocate(wovr) - - end if - -! 1-2-1 smoothing for variation height - - call sm121(varhgt,plon,plat,numlons) - call sm121(varhgt,plon,plat,numlons) - if (have_sgh30) then - call sm121(sgh30,plon,plat,numlons) - call sm121(sgh30,plon,plat,numlons) - end if -! -! get standard deviation for smoothed height field -! -! determine geopotential height field. The multiplication by 9.80616 -! causes phis to be only accurate to 32-bit roundoff on some machines -! - xmax = -1.d99 - do jo=1,plat - do io=1,numlons(jo) - if (varhgt(io,jo) < 0.5) then - sgh(io,jo) = 0. - else - sgh(io,jo) = sqrt(varhgt(io,jo)) - end if - if (have_sgh30) then - if (sgh30(io,jo) < 0.5) then - sgh30(io,jo) = 0. - else - sgh30(io,jo) = sqrt(sgh30(io,jo)) - end if - end if - if (sgh(io,jo) > xmax) then - xmax = sgh(io,jo) - imax = io - jmax = jo - end if - phis(io,jo) = mnhgt(io,jo) * 9.80616 - end do - end do - - if (verbose) write(6,*)'Max SGH =',xmax,' at i,j=', imax, jmax - - return -end subroutine sghphis diff --git a/tools/definesurf/shr_kind_mod.f90 b/tools/definesurf/shr_kind_mod.f90 deleted file mode 100644 index fc1ed8e94a..0000000000 --- a/tools/definesurf/shr_kind_mod.f90 +++ /dev/null @@ -1,20 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - -END MODULE shr_kind_mod diff --git a/tools/definesurf/sm121.f90 b/tools/definesurf/sm121.f90 deleted file mode 100644 index c4b491616a..0000000000 --- a/tools/definesurf/sm121.f90 +++ /dev/null @@ -1,86 +0,0 @@ -subroutine sm121 (a, plon, nlat, nlon) - - use shr_kind_mod, only: r8 => shr_kind_r8 - -! -! perform 1-2-1 smoothing using data array a. On reduced grid, linearly -! interpolate to a rectangular grid (nlon(j),3) before interpolating -! -!----------------------------------------------------------------------- - implicit none -!-----------------------------Arguments--------------------------------- - - integer plon ! Input: Lon dim - integer nlat ! Input: Lat dim - integer nlon(nlat) ! Number of longitudes per latitude - real(r8) a(plon,nlat) ! I/O: Array to be smoothed - -!--------------------------Local variables------------------------------ - - integer i,j ! Indices - integer imin,imax ! Indices - integer jmax,jmin ! Indices -! -! Dynamic -! - real(r8) xin(plon,nlat) - real(r8) xout(plon) - real(r8) temp(plon,nlat) ! Temp array - real(r8) tempjmin(plon) ! Temp array - real(r8) tempjmax(plon) ! Temp array -! -!----------------------------------------------------------------------- -! - temp(:,:) = a(:,:) -! -! first do the S and N boundaries. -! - do i=1,nlon(1) - imin = i - 1 - imax = i + 1 - if( imin .lt. 1 ) imin = imin + nlon(1) - if( imax .gt. nlon(1)) imax = imax - nlon(1) - a(i,1) = (temp(imin,1) + 3.*temp(i,1) +temp(imax,1))/5. - end do - - do i=1,nlon(nlat) - imin = i - 1 - imax = i + 1 - if( imin .lt. 1 ) imin = imin + nlon(nlat) - if( imax .gt. nlon(nlat)) imax = imax - nlon(nlat) - a(i,nlat) = (temp(imin,nlat)+3.*temp(i,nlat)+temp(imax,nlat))/5. - end do -! -! Define xin array for each latitude -! - do j=1,nlat - do i=1,nlon(j) - xin(i,j) = (i-1)*360./nlon(j) - end do - end do -! -! Linearly interpolate data N and S of each target latitude to the longitudes -! of each target latitude before applying 1-2-1 filter -! - do j=2,nlat-1 - jmin = j - 1 - jmax = j + 1 - xout(:) = xin(:,j) - call lininterp (temp(1,jmin), nlon(jmin), 1, xin(1,jmin), & - tempjmin, nlon(j), 1, xout, .true.) - call lininterp (temp(1,jmax), nlon(jmax), 1, xin(1,jmax), & - tempjmax, nlon(j), 1, xout, .true.) - - do i=1,nlon(j) - imin = i - 1 - imax = i + 1 - if( imin .lt. 1 ) imin = imin + nlon(j) - if( imax .gt. nlon(j)) imax = imax - nlon(j) - a(i,j) = (tempjmin(i) + & - temp(imin,j) + 4.*temp(i,j) + temp(imax,j) + & - tempjmax(i) ) / 8. - enddo - enddo -! - return -end subroutine sm121 diff --git a/tools/definesurf/terrain_filter.f90 b/tools/definesurf/terrain_filter.f90 deleted file mode 100644 index fb80d9c492..0000000000 --- a/tools/definesurf/terrain_filter.f90 +++ /dev/null @@ -1,320 +0,0 @@ -! Terrain Filter -! -! Contributed by S.J. Lin. -! -! Added to the definesurf program by G. Grant, 30 June 2000. -! Updated with latest version from S.J. by B. Eaton, 23 August 2001 -! -! Notes from S.J.: -! -! "I compute the unsmoothed mean height and the variance -! exactly the same as the standard CCM utility. The only difference -! is the grid being uniformly spaced from North pole to South pole. -! The filter is applied to the mean height and the sqaure root of -! the variance (the standard deviation). -! -! For the 2x2.5 deg resolution -! -! mlon = 144 -! mlat = 91 -! -! Assuming the mean height is Z(mlon,mlat), and the standard deviation -! (the sqaure root of the variance) is SD(moln,mlat), the filter -! algorithm goes like this: -! -! call sm2(mlon, mlat, Z, itmax_Z, 0.25D0) -! call sm2(mlon, mlat, SD, itmax_SD, 0.25D0) -! -! where 0.25D0 is the dimensionless filter coefficient, and -! -! itmax_Z = 2*mlat -! itmax_SD = mlon -! -! [As discussed elsewhere] the above filtering is a bit too strong. -! But it is the filter I used up to now. -! I am currently testing the following setting -! -! itmax_Z = mlat/2 -! itmax_SD = mlon/4 -! " - - - subroutine sm2(im, jm, ht, itmax, c) -! -! Del-2 diffusion on the sphere -! - implicit none - -! Input: - integer im ! e-w dimension (eg, 144 for 2.5 deg resolution) - integer jm ! n-s doemsnion (eg, 91 for 2 deg resolution) - integer itmax ! iteration count - real*8 c ! filter coefficient - -! Input/Output - real*8 ht(im,jm) ! array to be filtered - -! Local - real*8 dg(im,jm) ! del2 of h - real*8 cose(jm), cosp(jm), sinp(jm), sine(jm) - real*8 dl - real*8 dp - real*8 fmin, fmax - integer jm1 - integer mnk, mxk - integer ndeg - integer it, i, j - real*8 s1, s2 - - jm1 = jm-1 - - call setrig(im, jm, dp, DL, cosp, cose, sinp, sine) - - call pmnx(ht, im, jm, fmin, fmax, mnk, mxk) - write(6,*) 'hmax=', fmax,' at j= ',mxk - write(6,*) 'hmin=', fmin,' at j= ',mnk - - ndeg = 60 ! starting latitude for the monotonicity - ! preserving polar filter - - call pmnx(ht,im,jm,fmin,fmax,mnk,mxk) - write(6,*) 'hmax=', fmax,' at j= ',mxk - write(6,*) 'hmin=', fmin,' at j= ',mnk - -! Apply Monotonicity preserving polar filter - call plft2d(im, jm, ht, 2, jm1, ndeg) - call avgp2(ht, sine, im, jm) - - do it=1,itmax - call del2(ht, im, jm, dg, cosp, cose, sine, DL, dp, ndeg) - call plft2d(im, jm, dg, 2, jm1, ndeg) - - do j=1,jm - do i=1,im - ht(i,j) = ht(i,j) + c*dg(i,j) - enddo - enddo - enddo - -! Final polar filter - call plft2d(im, jm, ht, 2, jm1, ndeg) - - return - end - - subroutine del2(h, im, jm, dg, cosp, cose, sine, dL, dp, ndeg) - implicit none - -! AE = 1 (unit radius) -! Input: - integer im - integer jm - integer ndeg -! Input-output - - real*8 h(im,jm) - real*8 dg(im,jm) ! del2 of h - real*8 cose(jm),cosp(jm) - real*8 sine(jm) - real*8 PI, ycrit, coszc, CD - real*8 DL, dp - -! Local - real*8 fx(im,jm) ! e-w fluxes - real*8 fy(im,jm) ! n-s fluxes - integer i, j - - call grad(h, im, jm, fx, fy, cosp, dl, dp) - - PI = 4. * ATAN(1.) - ycrit = float(ndeg)*PI/180. - coszc = cos(ycrit) - - CD = 0.25*DL*DP*coszc**2 -! CD = 0.25*DL*DP*cosp(2)**2 - - do j=2,jm-1 - do i=1,im - fx(i,j) = fx(i,j) * CD - enddo - enddo - - do j=2,jm - do i=1,im - fy(i,j) = fy(i,j) * CD - enddo - enddo - - call divg(im,jm,fx,fy,DG,cosp,cose,sine, dl, dp) - - return - end - - subroutine divg(im, jm, fx, fy, dg, cosp, cose, sine, dl, dp) - implicit none - - integer im - integer jm - real*8 fx(im,jm) ! e-w fluxes - real*8 fy(im,jm) ! n-s fluxes - real*8 DG(im,jm) ! del2 of h - real*8 wk(im,jm) - real*8 cosp(jm), cose(jm), sine(jm) - real*8 rdx - real*8 dl, dp, CDP, sum1, sum2 - integer i,j - - do j=2,jm-1 - - rdx = 1./ (cosp(j)*DL) - - do i=1,im-1 - DG(i,j) = (fx(i+1,j) - fx(i,j)) * rdx - enddo - DG(im,j) = (fx(1,j) - fx(im,j)) * rdx - enddo - - do j=2,jm - do i=1,im - wk(i,j) = fy(i,j) * cose(j) - enddo - enddo - - do j=2,jm-1 - CDP = 1./ (DP*cosp(j)) - do i=1,im - DG(i,j) = DG(i,j) + (wk(i,j+1) - wk(i,j)) * CDP - enddo - enddo - -! Poles; - - sum1 = wk(im, 2) - sum2 = wk(im,jm) - - do i=1,im-1 - sum1 = sum1 + wk(i, 2) - sum2 = sum2 + wk(i,jm) - enddo - - sum1 = sum1 / ( float(im)*(1.+sine(2)) ) - sum2 = -sum2 / ( float(im)*(1.+sine(2)) ) - - do i=1,im - DG(i, 1) = sum1 - DG(i,jm) = sum2 - enddo - - return - end - - subroutine grad(h, im, jm, fx, fy, cosp, DL, DP) - implicit none - integer im - integer jm - real*8 h(im,jm) - real*8 fx(im,jm) ! e-w fluxes - real*8 fy(im,jm) ! n-s fluxes - real*8 cosp(jm) - real*8 RDP, DL, DP, rdx - integer i, j - - RDP = 1./ DP - - do j=2,jm - do i=1,im - fy(i,j) = (h(i,j) - h(i,j-1)) * RDP - enddo - enddo - - do j=2,jm-1 - - rdx = 1./ (cosp(j)*DL) - fx(1,j) = (h(1,j) - h(im,j)) * rdx - do i=2,im - fx(i,j) = (h(i,j) - h(i-1,j)) * rdx - enddo - enddo - - return - end - - subroutine avgp2(p, sine, im, jm) - implicit none - integer im, jm - real*8 p(im,jm) - real*8 sine(jm) - real*8 sum1, sum2 - real*8 sum3, sum4 - real*8 rim - integer i - integer j - integer jm1 - - jm1 = jm-1 - rim = 1./ float(im) - - call sump2(p(1,1),p(1,jm),IM,sum1,sum2) - sum1 = sum1*(1.+sine(2)) - sum2 = sum2*(1.+sine(2)) - - call sump2(p(1,2),p(1,jm1),IM,sum3,sum4) - sum1 = rim * ( sum1 + sum3*(sine(3)-sine(2)) ) / (1.+sine(3)) - sum2 = rim * ( sum2 + sum4*(sine(3)-sine(2)) ) / (1.+sine(3)) - - do i=1,im - P(i, 1) = sum1 - P(i, 2) = sum1 - P(i,jm1) = sum2 - P(i, jm) = sum2 - enddo - return - end - - subroutine sump2(p1,p2,im,s1,s2) - implicit none - integer im,i - real*8 s1,s2 - real*8 p1(*),p2(*) - - s1 = p1(im) - s2 = p2(im) - - do i=1,im-1 - s1 = s1 + p1(i) - s2 = s2 + p2(i) - enddo - return - end - - subroutine pmnx(a,nx,ny,fmin,fmax,mnk,mxk) - implicit none - integer nx - integer ny - integer mnk - integer mxk - real*8 a(nx,*) - real*8 fmax, fmin, temp - integer i,j - - fmax = a(1,1) - fmin = a(1,1) - mnk = 1 - mxk = 1 - - do j=1,ny - do i=1,nx - temp = a(i,j) - if(temp.gt.fmax) then - fmax = temp - mxk = j - elseif(temp .lt. fmin) then - fmin = temp - mnk = j - endif - enddo - enddo - - return - end - diff --git a/tools/definesurf/varf2c.f90 b/tools/definesurf/varf2c.f90 deleted file mode 100644 index c7f638ff41..0000000000 --- a/tools/definesurf/varf2c.f90 +++ /dev/null @@ -1,219 +0,0 @@ -subroutine varf2c(flon ,flat ,nflon ,nflat ,fine , & - clon ,clat ,nclon ,nclat ,cmean , & - cvar ) - - use shr_kind_mod, only: r8 => shr_kind_r8 - -!----------------------------------------------------------------------------- -! Bin going from a fine grid to a coarse grid. -! A schematic for the coarse and fine grid systems is shown in -! Figure 1. This code assumes that each data point is represent -! it's surrounding area, called a cell. The first grid data point -! for both grids is assumed to be located at 0E (GM). This -! implies that the 1st cell for both the fine and the coarse grids -! strattles the Greenwich Meridian (GM). This code also assumes -! that there is no data wraparound (last data value is located at -! 360-dx). -! -! FIGURE 1: Overview of the coarse (X) and fine (@) grids -! longitudinal structure where: -! X = location of each coarse grid data point -! @ = location of each fine grid data point -! -! Greenwich Greenwich -! 0 Coarse cells 360 -! : v : -! clon(1): clon(2) v clon(3) clon(nclon): -! v : v v v v : -! xxxxxxxxxxxxxxxxxxxxxxxxxxxx..xxxxxxxxxxxxxxxx : -! x x x x x : -! x x x x x : -! x c(1) x c(2) x x c(nclon)x : -! x X x X x x X x : -! x ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ : -! x | | | | | | | | | | | | | : -! x | @ | @ | @ | @ | @ | @ |..| @ | @ | @ | @ | @ | : -! xxx|___|___|___|___|___|___| |___|___|___|___|___| : -! v v v v v : -! flon(1) flon(3) v flon(nflon-1) flon(nflon) -! : v : -! : Fine cells : -! 0 360 -! -! The Longitude/Latitude search: -! ------------------------------ -! -! Given a coarse grid cell with west and east boundaries of cWest -! and cEast and south and north boundaries of cSouth and cNorth -! (outlined by "x" in figure 2), find the indices of the fine grid -! points which are contained within the coarse grid cell. imin and -! imax are the indices fine grid points which overlap the western -! and eastern boundary of the coarse cell. jmin and jmax are the -! corresponding indices in the S-N direction. Bin these overlapping -! values to generate coarse(n), the coarse grid data values. -! -! FIGURE 2: Detail of Coarse and Fine cell overlap. -! @ = fine grid data point -! X = coarse grid data point -! -! cWest cEast -! | | x | | x | -! -@-------@---x---@-------@-----x-@- -! | | x*xxxxxxxxxxxxxxxxx*x|xx cNorth -! | | x | | x | -! | | x | | x | -! @-------@---x---@-------@-----x-@- jmax -! | | x | c(n) | x | -! | @ | x | | x | -! | | x | | x | -! @-------@---x---@-------@-----x-@- jmin -! | | x | | x | -! | @ | x*xxxxxxx@xxxxxxxxx*x|xx cSouth -! | | x | | x | -! -@-------@---x---@-------@-----x-@- -! | imin imax | -! -! -! When a cell coarse cell strattles the Greenwich Meridian -! --------------------------------------------------------- -! -! The first coarse grid cell strattles the GM, so when the western -! boundary of the coarse cell is < 0, an additional search is carried out. -! It ASSUMES that the easternmost fine grid point overlaps and searches -! westward from nflon, looking for a grid point west of clon(1) -! This generates a second set of longitudinal indices, imin1 and imax1. -! See Figure 3. -! -! Figure 3: Detail of Coarse cell strattling GM: -! ----------------------------------------------- -! -! Greenwich Greenwich -! 0 360 -! cWest : cEast cWest : -! clon(1): clon(2) clon(nclon+1)=clon(1) -! v : v v : -! xxxxxxxxxxxxxxxxxxxxxxx ... xxxxxxxxxxxxxxxx : -! x x x x x : -! x x x x x : -! x c(1) x x x c(nclon)x : -! x X x x x X x : -! x ___ ___ ___ _ ___ ___ ___ : -! x | | | | | | | : -! x | @ | @ | @ | @ | @ | @ | : -! xxx|___|___|___|_ ___|___|___| : -! ^ : ^ ^ ^ ^ : -! flon(1): ^ flon(3) flon(nflon-1) ^ : -! ^ : ^ ^ ^ : -! ^ :flon(2) ^ flon(nflon) -! ^ : ^ ^ ^ : -! imin : imax imin1 imax1 : -! : : -! -! -! In this case, imin=1, imax=2, imin1=nflon-1 and imax1=nflon. -! because the last two cells of the fine grid will have some -! contribution the the 1st cell of the coarse grid. -! -!----------------------------------------------------------------------- - implicit none -!-----------------------------Arguments--------------------------------- - - integer nflon ! Input: number of fine longitude points - integer nflat ! Input: number of fine latitude points - integer nclon ! Input: number of coarse longitude points - integer nclat ! Input: number of coarse latitude points - - real(r8) flon(nflon) ! Input: fine grid lons, centers (deg) - real(r8) flat(nflat) ! Input: fine grid lats, centers (deg) - real(r8) fine(nflon,nflat) ! Input: Fine grid data array - real(r8) clon(nclon+1,nclat) ! Input: coarse grid cell lons, west edge (deg) - real(r8) clat(nclat+1) ! Input: coarse grid cell lat, south edge (deg) - real(r8) cmean(nclon,nclat) ! Input: mean of fine points over coarse grid cell - real(r8) cvar (nclon,nclat) ! Output:variance of fine points over coarse cell - -!--------------------------Local variables------------------------------ - - real(r8) cWest ! Coarse cell longitude, west edge (deg) - real(r8) cEast ! Coarse cell longitude, east edge (deg) - real(r8) cSouth ! Coarse cell latitude, south edge (deg) - real(r8) cNorth ! Coarse cell latitude, notrh edge (deg) - real(r8) sum ! coarse tmp value - - integer i,j ! Indices - integer imin ,imax ! Max/Min E-W indices of intersecting fine cell. - integer imin1,imax1 ! fine E-W indices when coarse cell strattles GM - integer jmin ,jmax ! Max/Min N-S indices of intersecting fine cell. - integer iclon,jclat ! coarse grid indices - integer num ! increment - -!----------------------------------------------------------------------------- - - do jclat= 1,nclat ! loop over coarse latitudes - cSouth = clat(jclat) - cNorth = clat(jclat+1) - - do iclon=1,nclon ! loop over coarse longitudes - cWest = clon(iclon,jclat) - cEAST = clon(iclon+1,jclat) - -! 1. Normal longitude search: Find imin and imax - - imin = 0 - imax = 0 - do i=1,nflon-1 ! loop over fine lons, W -> E - if (flon(i) .gt. cEast) goto 10 ! fine grid point is E of coarse box - if (flon(i) .ge. cWest .and. imin.eq.0) imin=i - imax=i - enddo - -! 2. If cWest < 0, then coarse cell strattles GM. Hunt westward -! from the end to find indices of any overlapping fine grid cells: -! imin1 and imax1. - -10 imin1 = 0 ! borders for cWest, cEast - imax1 = -1 ! borders for cWest, cEast - if (cWest .lt. 0) then - cWest = cWest + 360. - imax1 = nflon - do i=nflon,1,-1 ! loop over fine lons, E -> W - imin1=i - if (flon(i) .le. cWest) goto 20 ! fine grid point is W of coarse box - enddo - endif - -! 3. Do the latitude search S -> N for jmin and jmax - -20 jmin = 0 - jmax = 0 - do j=1,nflat ! loop over fine lats, S -> N - if (flat(j) .gt. cNorth) goto 30 ! fine grid point is N of coarse box - if (flat(j) .ge. cSouth .and. jmin.eq.0) jmin=j - jmax=j - enddo -30 continue - -! 4. Sdv - - sum = 0. ! Initialize coarse data value - num = 0 - - do j=jmin,jmax ! loop over fine lats, S -> N - do i=imin,imax ! loop over fine lons, W -> E - sum = sum + (fine(i,j) - cmean(iclon,jclat))**2 - num = num + 1 - enddo - do i=imin1,imax1 ! If coarse cell strattles GM - sum = sum + (fine(i,j) - cmean(iclon,jclat))**2 - num = num + 1 - enddo - enddo - - if (num .gt. 0) then - cvar(iclon,jclat) = sum/num - else - cvar(iclon,jclat) = 1.e30 - endif - end do - end do - return -end subroutine varf2c diff --git a/tools/definesurf/wrap_nf.f90 b/tools/definesurf/wrap_nf.f90 deleted file mode 100644 index c340b3817b..0000000000 --- a/tools/definesurf/wrap_nf.f90 +++ /dev/null @@ -1,146 +0,0 @@ -subroutine wrap_inq_varid (nfid, varname, varid) - implicit none - include 'netcdf.inc' - - integer nfid, varid - character*(*) varname - - integer ret - - ret = nf_inq_varid (nfid, varname, varid) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_inq_varid - -subroutine wrap_inq_dimlen (nfid, dimid, dimlen) - implicit none - include 'netcdf.inc' - - integer nfid, dimid, dimlen - - integer ret - - ret = nf_inq_dimlen (nfid, dimid, dimlen) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_inq_dimlen - -subroutine wrap_inq_dimid (nfid, dimname, dimid) - implicit none - include 'netcdf.inc' - - integer nfid, dimid - character*(*) dimname - - integer ret - - ret = nf_inq_dimid (nfid, dimname, dimid) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_inq_dimid - -subroutine wrap_inq_var (nfid, varid, varname, xtype, ndims, dimids, natts) - implicit none - include 'netcdf.inc' - - integer nfid, varid, xtype, ndims, dimids(nf_max_dims), natts - character*(*) varname - - integer ret - - ret = nf_inq_var (nfid, varid, varname, xtype, ndims, dimids, natts) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_inq_var - -subroutine wrap_def_dim (nfid, dimname, len, dimid) - implicit none - include 'netcdf.inc' - - integer nfid, len, dimid - character*(*) dimname - - integer ret - - ret = nf_def_dim (nfid, dimname, len, dimid) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_def_dim - -subroutine wrap_get_var8 (nfid, varid, arr) - implicit none - include 'netcdf.inc' - - integer nfid, varid - real*8 arr(*) - - integer ret - - ret = nf_get_var_double (nfid, varid, arr) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_get_var8 - -subroutine wrap_put_var8 (nfid, varid, arr) - implicit none - include 'netcdf.inc' - - integer nfid, varid - real*8 arr(*) - - integer ret - ret = nf_put_var_double (nfid, varid, arr) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_put_var8 - -subroutine wrap_get_vara8 (nfid, varid, start, count, arr) - implicit none - include 'netcdf.inc' - - integer nfid, varid, start(*), count(*) - real*8 arr(*) - - integer ret - - ret = nf_get_vara_double (nfid, varid, start, count, arr) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_get_vara8 - -subroutine wrap_put_vara8 (nfid, varid, start, count, arr) - implicit none - include 'netcdf.inc' - - integer nfid, varid - integer start(*), count(*) - real*8 arr(*) - - integer ret - ret = nf_put_vara_double (nfid, varid, start, count, arr) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_put_vara8 - -subroutine wrap_put_att_text (nfid, varid, attname, atttext) - implicit none - include 'netcdf.inc' - - integer, intent(in):: nfid - integer, intent(in):: varid - character*(*), intent(in):: attname - character*(*), intent(in):: atttext - - integer ret ! NetCDF return code - integer siz - - siz = len_trim(atttext) - ret = nf_put_att_text (nfid, varid, attname, siz, atttext) - if (ret/=NF_NOERR) call handle_error (ret) -end subroutine wrap_put_att_text - -subroutine wrap_put_att_double (nfid, varid, name, xtype, len, dvals) - implicit none - include 'netcdf.inc' - - integer nfid, varid, xtype, len - character*(*) name - real*8 dvals - - integer ret - - ret = nf_put_att_double (nfid, varid, name, xtype, len, dvals) - if (ret.ne.NF_NOERR) call handle_error (ret) -end subroutine wrap_put_att_double - diff --git a/tools/topo_tool/bin_to_cube/Makefile b/tools/topo_tool/bin_to_cube/Makefile deleted file mode 100644 index 84d1b39138..0000000000 --- a/tools/topo_tool/bin_to_cube/Makefile +++ /dev/null @@ -1,82 +0,0 @@ -EXEDIR = . -EXENAME = bin_to_cube -RM = rm - -.SUFFIXES: -.SUFFIXES: .F90 .o - - -# -# setenv LD_LIBRARY_PATH ${LD_LIBRARY_PATH}:/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib -# - -FC = lf95 -#DEBUG=TRUE - -# Check for the NetCDF library and include directories -ifeq ($(LIB_NETCDF),$(null)) -LIB_NETCDF := /usr/local/lib -endif - -ifeq ($(INC_NETCDF),$(null)) -INC_NETCDF := /usr/local/include -endif - -# Determine platform -UNAMES := $(shell uname -s) -UNAMEM := $(findstring CRAY,$(shell uname -m)) - - -#------------------------------------------------------------------------ -# LF95 -#------------------------------------------------------------------------ - -ifeq ($(FC),lf95) -# -# Tramhill -# - INC_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/include - LIB_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib - - LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -lnetcdff -lcurl -lhdf5 -lhdf5_hl -mcmodel=medium - FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF) - ifeq ($(DEBUG),TRUE) - #TBH: this works FFLAGS += -g --chk --pca - #TBH: this FAILS FFLAGS += -g --chk a,e,s,u,x --pca - FFLAGS += -g --chk a,e,s,u --pca - else - FFLAGS += -O - endif - -endif - - -#------------------------------------------------------------------------ -# AIX -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),AIX) -FC = xlf90 -FFLAGS = -c -I$(INC_NETCDF) -LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -.F90.o: - $(FC) $(FFLAGS) -qsuffix=f=F90 $< -endif - - -.F90.o: - $(FC) $(FFLAGS) $< - -#------------------------------------------------------------------------ -# Default rules and macros -#------------------------------------------------------------------------ - -OBJS := bin_to_cube.o shr_kind_mod.o - -$(EXEDIR)/$(EXENAME): $(OBJS) - $(FC) -o $@ $(OBJS) $(LDFLAGS) - -clean: - $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME) - -bin_to_cube.o: shr_kind_mod.o diff --git a/tools/topo_tool/bin_to_cube/README b/tools/topo_tool/bin_to_cube/README deleted file mode 100644 index aa65664798..0000000000 --- a/tools/topo_tool/bin_to_cube/README +++ /dev/null @@ -1,23 +0,0 @@ -This program reads USGS 30-sec terrain dataset from NetCDF file and bins it to an approximately -3km cubed-sphere grid and outputs the data in netCDF format. - -The LANDM_COSLAT field is read in from a separate netCDF file and linearly interpolated to the 3km cubed-sphere grid. - -Input files needed: - -1. USGS raw data in netCDF format: usgs-rawdata.nc (must be placed in same dirctory as the executables) - Generated with software in gen_netCDF_from_USGS/ directory - - File may be found at: - - $CESMDATA/inputdata/atm/cam/gtopo30data/usgs-rawdata.nc - -2. landm_coslat dataset (must be placed in same dirctory as the executables). E.g.: - - ln -s /fs/cgd/csm/inputdata/atm/cam2/hrtopo/landm_coslat.nc . - - The landm_coslat field is not used in CAM5! - -Output file: - -USGS-topo-cube.nc diff --git a/tools/topo_tool/bin_to_cube/bin_to_cube.F90 b/tools/topo_tool/bin_to_cube/bin_to_cube.F90 deleted file mode 100644 index 89ea086a37..0000000000 --- a/tools/topo_tool/bin_to_cube/bin_to_cube.F90 +++ /dev/null @@ -1,931 +0,0 @@ -! -! DATE CODED: Nov 7, 2011 -! -! DESCRIPTION: This program reads USGS 30-sec terrain dataset from NetCDF file and -! bins it to an approximately 3km cubed-sphere grid and outputs the -! data in netCDF format. -! -! The LANDM_COSLAT field is read in from a separate netCDF file and linearly -! interpolated to the 3km cubed-sphere grid. -! -! Author: Peter Hjort Lauritzen (pel@ucar.edu) -! -! ROUTINES CALLED: -! netcdf routines -! -! COMPILING: -! -program convterr - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none -# include - ! - integer :: im, jm - - integer, parameter :: ncube = 3000 !dimension of cubed-sphere grid -! integer, parameter :: ncube = 540 !dimension of cubed-sphere grid - ! integer, parameter :: ncube = 361 ! for debugging - - integer*2, allocatable, dimension(:,:) :: terr ! global 30-sec terrain data - integer*1, allocatable, dimension(:,:) :: landfrac ! global 30-sec land fraction - - integer :: alloc_error,dealloc_error - integer :: i,j,n,k,index ! index - integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile - integer ncid,status, dimlatid,dimlonid, landid, topoid ! for netCDF USGS data file - integer :: srcid,dstid ! for netCDF weight file - - real(r8), allocatable, dimension(:) :: lon , lat - real(r8), allocatable, dimension(:) :: lon_landm , lat_landm - real(r8), allocatable, dimension(:,:) :: landm_coslat - integer :: im_landm, jm_landm - integer :: lonid, latid - integer :: lon_vid, lat_vid - - REAL (r8), PARAMETER :: tiny = 1.0E-10 - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: rad2deg = 180.0/pi - REAL (r8), PARAMETER :: deg2rad = pi/180.0 - - real(r8) :: alpha, beta,da,wt,dlat - integer :: ipanel,icube,jcube - real(r8), allocatable, dimension(:,:,:) :: weight,terr_cube,landfrac_cube,sgh30_cube - real(r8), allocatable, dimension(:,:,:) :: landm_coslat_cube - integer , allocatable, dimension(:,:) :: idx,idy,idp - ! - real(r8) :: dx,dy - ! - ! for "bi-linear" interpolation - ! - real(r8) :: lambda,theta,wx,wy - integer :: ilon,ilat,ip1,jp1 - ! - ! variable for regridding - ! - integer :: src_grid_dim ! for netCDF weight file - ! - ! this is only used if target grid is a lat-lon grid - ! - integer , parameter :: im_target = 360 , jm_target = 180 - logical , parameter :: ltarget_rll = .TRUE. - ! - ! this is only used if target grid is not a lat-lon grid - ! - real(r8), allocatable, dimension(:) :: lon_target, lat_target - ! - ! compute volume of surface topography - ! - real(r8) :: vol,dx_rad,vol_cube,area_latlon,darea_latlon ! latitude array - real(r8), allocatable, dimension(:,:) :: darea_cube - - ! - ! read in USGS data from netCDF file - ! - ! status = nf_open('topo-lowres.nc', 0, ncid) !for debugging - status = nf_open('usgs-rawdata.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'lat', dimlatid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimlatid, jm) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_INQ_DIMID(ncid, 'lon', dimlonid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimlonid, im) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "lon-lat dimensions: ",im,jm - - allocate ( landfrac(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - allocate ( terr(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr' - stop - end if - - allocate ( lon(im),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - allocate ( lat(jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - terr = -999999 - landfrac = -99.0 - - status = NF_INQ_VARID(ncid, 'landfract', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_INT1(ncid, landid,landfrac) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of 30sec land fraction",MINVAL(landfrac),MAXVAL(landfrac) - - - status = NF_INQ_VARID(ncid, 'htopo', topoid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "read terrain data" - status = NF_GET_VAR_INT2(ncid, topoid,terr) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_INQ_VARID(ncid, 'lon', lonid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "read lon" - status = NF_GET_VAR_DOUBLE(ncid, lonid,lon) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_INQ_VARID(ncid, 'lat', latid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "read lat" - status = NF_GET_VAR_DOUBLE(ncid, latid,lat) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - print *,"close file topo.nc" - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - - WRITE(*,*) 'done reading in USGS data from netCDF file' - - WRITE(*,*) "Adjustments to land fraction: Extend land fraction for Ross Ice shelf by" - WRITE(*,*) "setting all landfractions south of 79S to 1" - DO j=1,jm - IF (lat(j)<-79.0) THEN - DO i=1,im - landfrac(i,j) = 1 - END DO - END IF - END DO - - WRITE(*,*) "compute volume for USGS raw data" - vol = 0.0 - dx = (lon(2)-lon(1)) - dx_rad = dx*deg2rad - do j=1,jm - do i=1,im - darea_latlon = dx_rad*(SIN(deg2rad*(-90.0+dx*j))-SIN(deg2rad*(-90.0+dx*(j-1)))) - vol = vol+DBLE(terr(i,j))*darea_latlon - area_latlon = area_latlon + darea_latlon - end do - end do - vol = vol/area_latlon - WRITE(*,*) "consistency of lat-lon area",area_latlon-4.0*pi - WRITE(*,*) "volume of topography about sea-level (raw usgs data)",vol - - - ! - !**************************************************** - ! - ! read LANDM_COSLAT - ! - !**************************************************** - ! - WRITE(*,*) "read LANDM_COSLAT from file" - status = nf_open('landm_coslat.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'lat', dimlatid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimlatid, jm_landm) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_INQ_DIMID(ncid, 'lon', dimlonid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimlonid, im_landm) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "lon-lat dimensions: ",im_landm,jm_landm - - allocate ( landm_coslat(im_landm,jm_landm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - allocate ( lon_landm(im_landm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - allocate ( lat_landm(jm_landm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - do j = 1, jm_landm - do i = 1, im_landm - landm_coslat(i,j) = -999999.99 - end do - end do - - status = NF_INQ_VARID(ncid, 'LANDM_COSLAT', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,landm_coslat) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of landm_coslat",MINVAL(landm_coslat),MAXVAL(landm_coslat) - - status = NF_INQ_VARID(ncid, 'lon', lonid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "read lon" - status = NF_GET_VAR_DOUBLE(ncid, lonid,lon_landm) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_INQ_VARID(ncid, 'lat', latid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - WRITE(*,*) "read lat" - status = NF_GET_VAR_DOUBLE(ncid, latid,lat_landm) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - print *,"close file" - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - - WRITE(*,*) 'done reading in LANDM_COSLAT data from netCDF file' - - ! - ! bin data on cubed-sphere grid - ! - da = pi / DBLE(2*ncube)!equal-angle cubed-sphere grid spacing - lon = deg2rad*lon - lat = deg2rad*lat - dlat = pi/DBLE(jm) - allocate ( weight(ncube,ncube,6),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for weight' - stop - end if - weight = 0.0 - allocate ( terr_cube(ncube,ncube,6),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr_cube' - stop - end if - terr_cube = 0.0 - allocate ( landfrac_cube(ncube,ncube,6),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr_cube' - stop - end if - landfrac_cube = 0.0 - allocate ( landm_coslat_cube(ncube,ncube,6),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr_cube' - stop - end if - landm_coslat_cube = 0.0 - - - allocate ( idx(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for idx' - stop - end if - allocate ( idy(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for idy' - stop - end if - allocate ( idp(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for idp' - stop - end if - - WRITE(*,*) "bin lat-lon data on cubed-sphere" - - ! - ! for debugging ONLY - ! -! DO j=1,jm -! DO i=1,im -!! terr(i,j) = 10000.0*(2.0+cos(lat(j))*cos(lat(j))*cos(2.0*lon(i)))!Y22 -!! terr(i,j) = 10000.0*(2.0+(sin(2.0*lat(j))**16)*cos(16.0*lon(i))) !Y16_32 -! terr(i,j) = 10000.0*(2.0+cos(16.0*lon(i))) !Y16_32 -! END DO -! END DO - - DO j=1,jm - DO i=1,im -! WRITE(*,*) "bin to cube ",100.0*FLOAT(i+(j-1)*im)/FLOAT(im*jm),"% done" - call CubedSphereABPFromRLL(lon(i), lat(j), alpha, beta, ipanel) - icube = CEILING((alpha + piq) / da) - jcube = CEILING((beta + piq) / da) - IF (icube<1.OR.icube>ncube.OR.jcube<1.OR.jcube>ncube) THEN - WRITE(*,*) "fatal error in search algorithm" - WRITE(*,*) "icube or jcube out of range: ",icube,jcube - STOP - END IF - wt = SIN( lat(j)+0.5*dlat ) - SIN( lat(j)-0.5*dlat ) - weight(icube,jcube,ipanel) = weight(icube,jcube,ipanel)+wt - ! - terr_cube (icube,jcube,ipanel) = terr_cube (icube,jcube,ipanel)+wt*DBLE(terr(i,j)) - landfrac_cube(icube,jcube,ipanel) = landfrac_cube(icube,jcube,ipanel)+wt*DBLE(landfrac(i,j)) - ! - ! save "index-association" for variance computation - ! - idx(i,j) = icube - idy(i,j) = jcube - idp(i,j) = ipanel - END DO - END DO - - dx = deg2rad*(lon_landm(2)-lon_landm(1)) - ! - ! lat_landm is not exactly equally spaced so a search is needed in the loop below - ! - dy = deg2rad*(lat_landm(2)-lat_landm(1)) - DO k=1,6 - DO j=1,ncube - DO i=1,ncube - IF (ABS(weight(i,j,k))<1.0E-9) THEN - WRITE(*,*) "there is no lat-lon grid point in cubed sphere cell ",i,j,k - WRITE(*,*) "fatal error" - STOP - ELSE - terr_cube (i,j,k) = terr_cube (i,j,k)/weight(i,j,k) - landfrac_cube (i,j,k) = landfrac_cube (i,j,k)/weight(i,j,k) - END IF - ! - ! linearly interpolate landm_coslat - ! - alpha = -piq+(i-0.5)*da - beta = -piq+(j-0.5)*da - CALL CubedSphereRLLFromABP(alpha, beta, k, lambda, theta) - IF (theta>lat_landm(jm_landm)*deg2rad-tiny) THEN - landm_coslat_cube(i,j,k) = 0.0 - ELSE IF (theta1.0.OR.wy<0.0) - jp1 = ilat+1 - wy = (theta -lat_landm(ilat)*deg2rad)/((lat_landm(jp1)-lat_landm(ilat))*deg2rad) - IF (wy>1.0) THEN - ilat=ilat+1 - ELSE IF (wy<0.0) THEN - ilat=ilat-1 - END IF - END DO - - IF (wx>1.0+tiny.OR.wx<0.0-tiny) THEN - WRITE(*,*) "wx out of range",wx - stop - END IF - IF (wy>1.0+tiny.OR.wy<0.0-tiny) THEN - WRITE(*,*) "wy out of range",wy - stop - END IF - ! - ! "crude" bi-linear interpolation - ! - landm_coslat_cube(i,j,k) =& - (1.0-wx)*(1.0-wy)*landm_coslat(ilon,ilat)+ wx *(1-wy)*landm_coslat(ip1,ilat)+& - (1.0-wx)* wy *landm_coslat(ilon,jp1 )+ wx * wy *landm_coslat(ip1,jp1) - END IF - END DO - END DO - END DO - WRITE(*,*) "min/max value of terr_cube:", MINVAL(terr_cube), MAXVAL(terr_cube) - WRITE(*,*) "min/max value of landm_coslat_cube:", MINVAL(landm_coslat_cube), MAXVAL(landm_coslat_cube) - ! - ! compute volume of topography on cubed-sphere - ! - WRITE(*,*) "compute volume for cubed-sphere binned data" - allocate (darea_cube(ncube,ncube),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for idp' - stop - end if - CALL EquiangularAllAreas(ncube, darea_cube) - vol_cube = 0.0 - do ipanel=1,6 - do j=1,ncube - do i=1,ncube - vol_cube = vol_cube+terr_cube(i,j,ipanel)*darea_cube(i,j) - end do - end do - end do - vol_cube=vol_cube/(4.0*pi) - deallocate(darea_cube) - WRITE(*,*) "mean height (globally) of topography about sea-level (3km cube data)",vol_cube,(vol_cube-vol)/vol - !********************************************************* - ! - ! compute variance - ! - !********************************************************* - ! - allocate ( sgh30_cube(ncube,ncube,6),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for sgh30_cube' - stop - end if - sgh30_cube = 0.0 - DO j=1,jm - DO i=1,im - icube = idx(i,j) - jcube = idy(i,j) - ipanel = idp(i,j) - wt = SIN( lat(j)+0.5*dlat ) - SIN( lat(j)-0.5*dlat ) - sgh30_cube(icube,jcube,ipanel) = sgh30_cube(icube,jcube,ipanel) + & - (wt*(terr_cube(icube,jcube,ipanel)-terr(i,j))**2)/weight(icube,jcube,ipanel) - END DO - END DO - ! sgh30_cube=sgh30_cube/weight - WRITE(*,*) "min/max value of sgh30_cube:", MINVAL(sgh30_cube), MAXVAL(sgh30_cube) - ! - ! write data to NetCDF file - ! - CALL wrt_cube(ncube,terr_cube,landfrac_cube,landm_coslat_cube,sgh30_cube) - DEALLOCATE(weight,terr,landfrac,idx,idy,idp,lat,lon) - WRITE(*,*) "done writing cubed sphere data" -end program convterr - - -!************************************************************************ -!!handle_err -!************************************************************************ -! -!!ROUTINE: handle_err -!!DESCRIPTION: error handler -!-------------------------------------------------------------------------- - -subroutine handle_err(status) - - implicit none - -# include - - integer status - - if (status .ne. nf_noerr) then - print *, nf_strerror(status) - stop 'Stopped' - endif - -end subroutine handle_err - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereABPFromRLL -! -! Description: -! Determine the (alpha,beta,panel) coordinate of a point on the sphere from -! a given regular lat lon coordinate. -! -! Parameters: -! lon - Coordinate longitude -! lat - Coordinate latitude -! alpha (OUT) - Alpha coordinate -! beta (OUT) - Beta coordinate -! ipanel (OUT) - Face panel -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (R8), INTENT(IN) :: lon, lat - REAL (R8), INTENT(OUT) :: alpha, beta - INTEGER, INTENT(OUT) :: ipanel - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: rotate_cube = 0.0 - - ! Local variables - REAL (R8) :: xx, yy, zz, pm - REAL (R8) :: sx, sy, sz - INTEGER :: ix, iy, iz - - ! Translate to (x,y,z) space - xx = COS(lon-rotate_cube) * COS(lat) - yy = SIN(lon-rotate_cube) * COS(lat) - zz = SIN(lat) - - pm = MAX(ABS(xx), ABS(yy), ABS(zz)) - - ! Check maximality of the x coordinate - IF (pm == ABS(xx)) THEN - IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF - ELSE - ix = 0 - ENDIF - - ! Check maximality of the y coordinate - IF (pm == ABS(yy)) THEN - IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF - ELSE - iy = 0 - ENDIF - - ! Check maximality of the z coordinate - IF (pm == ABS(zz)) THEN - IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF - ELSE - iz = 0 - ENDIF - - ! Panel assignments - IF (iz == 1) THEN - ipanel = 6; sx = yy; sy = -xx; sz = zz - - ELSEIF (iz == -1) THEN - ipanel = 5; sx = yy; sy = xx; sz = -zz - - ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN - ipanel = 1; sx = yy; sy = zz; sz = xx - - ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN - ipanel = 3; sx = -yy; sy = zz; sz = -xx - - ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN - ipanel = 2; sx = -xx; sy = zz; sz = yy - - ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN - ipanel = 4; sx = xx; sy = zz; sz = -yy - - ELSE - WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed' - WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')' - WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')' - STOP - ENDIF - - ! Use panel information to calculate (alpha, beta) coords - alpha = ATAN(sx / sz) - beta = ATAN(sy / sz) - -END SUBROUTINE CubedSphereABPFromRLL - - - -! -! write netCDF file -! -subroutine wrt_cube(ncube,terr_cube,landfrac_cube,landm_coslat_cube,sgh30_cube) - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none -# include - - ! - ! Dummy arguments - ! - integer, intent(in) :: ncube - real (r8), dimension(6*ncube*ncube), intent(in) :: terr_cube,landfrac_cube,sgh30_cube,landm_coslat_cube - ! - ! Local variables - ! - !----------------------------------------------------------------------- - ! - ! grid coordinates and masks - ! - !----------------------------------------------------------------------- - - real (r8), dimension(6*ncube*ncube) :: grid_center_lat ! lat/lon coordinates for - real (r8), dimension(6*ncube*ncube) :: grid_center_lon ! each grid center in degrees - - integer :: ncstat ! general netCDF status variable - integer :: nc_grid_id ! netCDF grid dataset id - integer :: nc_gridsize_id ! netCDF grid size dim id - integer :: nc_gridrank_id ! netCDF grid rank dim id - integer :: nc_griddims_id ! netCDF grid dimension size id - integer :: nc_grdcntrlat_id ! netCDF grid center lat id - integer :: nc_grdcntrlon_id ! netCDF grid center lon id - integer :: nc_terr_id - integer :: nc_landfrac_id - integer :: nc_landm_coslat_id - integer :: nc_var_id - - - integer, dimension(2) :: nc_dims2_id ! netCDF dim id array for 2-d arrays - integer :: grid_dims - - character(18), parameter :: grid_file_out = 'USGS-topo-cube.nc' - character(90), parameter :: grid_name = 'equi-angular gnomonic cubed sphere grid' - - character (len=32) :: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: status ! return value for error control of netcdf routin - integer :: i,j,k - character (len=8) :: datestring - - integer :: atm_add,n - real(r8) :: xgno_ce,lon,ygno_ce,lat - - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: rad2deg = 180.0/pi - - real(r8) :: da, a1,a2,a3,a4,dbg_area,max_size - real(r8), dimension(2,2) :: ang - real(r8) :: tmp_lon,min_lon,max_lon!,sum,lflag_value - logical :: lflag - - grid_dims = 6*ncube*ncube - - dbg_area = 0.0 - - da = pi / DBLE(2*ncube) - atm_add = 1 - do k=1,6 - do j=1,ncube - ygno_ce = -piq + da * (DBLE(j-1)+0.5) !center of cell - do i=1,ncube - xgno_ce = -piq + da * (DBLE(i-1)+0.5) - call CubedSphereRLLFromABP(xgno_ce, ygno_ce, k, lon, lat) - grid_center_lon(atm_add ) = lon*rad2deg - grid_center_lat(atm_add ) = lat*rad2deg - atm_add = atm_add+1 - end do - end do - end do - - WRITE(*,*) "Create NetCDF file for output" - ncstat = nf_create (grid_file_out, NF_64BIT_OFFSET,nc_grid_id) - call handle_err(ncstat) - - ncstat = nf_put_att_text (nc_grid_id, NF_GLOBAL, 'title',len_trim(grid_name), grid_name) - call handle_err(ncstat) - - WRITE(*,*) "define grid size dimension" - ncstat = nf_def_dim (nc_grid_id, 'grid_size', 6*ncube*ncube, nc_gridsize_id) - call handle_err(ncstat) - - WRITE(*,*) "define grid rank dimension" - ncstat = nf_def_dim (nc_grid_id, 'grid_rank', 1, nc_gridrank_id) - call handle_err(ncstat) - - WRITE(*,*) "define grid dimension size array" - ncstat = nf_def_var (nc_grid_id, 'grid_dims', NF_INT,1, nc_gridrank_id, nc_griddims_id) - call handle_err(ncstat) - - WRITE(*,*) "define grid center latitude array" - ncstat = nf_def_var (nc_grid_id, 'lat', NF_DOUBLE,1, nc_gridsize_id, nc_grdcntrlat_id) - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlat_id, 'units',13, 'degrees_north') - call handle_err(ncstat) - - WRITE(*,*) "define grid center longitude array" - ncstat = nf_def_var (nc_grid_id, 'lon', NF_DOUBLE,1, nc_gridsize_id, nc_grdcntrlon_id) - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlon_id, 'units',12, 'degrees_east') - call handle_err(ncstat) - - WRITE(*,*) "define terr_cube array" - ncstat = nf_def_var (nc_grid_id, 'terr', NF_DOUBLE,1, nc_gridsize_id, nc_terr_id) - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_terr_id, 'units',1, 'm') - call handle_err(ncstat) - - WRITE(*,*) "define landfrac_cube array" - ncstat = nf_def_var (nc_grid_id, 'LANDFRAC', NF_DOUBLE,1, nc_gridsize_id, nc_landfrac_id) - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_landfrac_id, 'long_name',70,& - 'land ocean transition mask: ocean (0), continent (1), transition (0-1)') - call handle_err(ncstat) - - WRITE(*,*) "define landm_coslat_cube array" - ncstat = nf_def_var (nc_grid_id, 'LANDM_COSLAT', NF_DOUBLE,1, nc_gridsize_id, nc_landm_coslat_id) - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_landm_coslat_id, 'long_name',35,'smoothed land ocean transition mask') - call handle_err(ncstat) - - WRITE(*,*) "define sgh30_cube array" - ncstat = nf_def_var (nc_grid_id, 'SGH30', NF_DOUBLE,1, nc_gridsize_id, nc_var_id) - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_var_id, 'units',12, 'm') - call handle_err(ncstat) - ncstat = nf_put_att_text (nc_grid_id, nc_var_id, 'long_name',58,& - 'variance of elevation from 30s lat-lon to 3km cubed-sphere') - - WRITE(*,*) "end definition stage" - ncstat = nf_enddef(nc_grid_id) - call handle_err(ncstat) - - !----------------------------------------------------------------------- - ! - ! write grid data - ! - !----------------------------------------------------------------------- - - - WRITE(*,*) "write grid data" - ncstat = nf_put_var_int(nc_grid_id, nc_griddims_id, grid_dims) - call handle_err(ncstat) - - ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, grid_center_lat) - call handle_err(ncstat) - - ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlon_id, grid_center_lon) - call handle_err(ncstat) - - ncstat = nf_put_var_double(nc_grid_id, nc_terr_id, terr_cube) - call handle_err(ncstat) - - ncstat = nf_put_var_double(nc_grid_id, nc_landfrac_id, landfrac_cube) - call handle_err(ncstat) - - ncstat = nf_put_var_double(nc_grid_id, nc_landm_coslat_id, landm_coslat_cube) - call handle_err(ncstat) - - ncstat = nf_put_var_double(nc_grid_id, nc_var_id, sgh30_cube) - call handle_err(ncstat) - - WRITE(*,*) "Close output file" - ncstat = nf_close(nc_grid_id) - call handle_err(ncstat) -end subroutine wrt_cube - - -!------------------------------------------------------------------------------ -! SUBROUTINE EquiangularAllAreas -! -! Description: -! Compute the area of all cubed sphere grid cells, storing the results in -! a two dimensional array. -! -! Parameters: -! icube - Resolution of the cubed sphere -! dA (OUT) - Output array containing the area of all cubed sphere grid cells -!------------------------------------------------------------------------------ -SUBROUTINE EquiangularAllAreas(icube, dA) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: icube - REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA - - ! Local variables - INTEGER :: k, k1, k2 - REAL (r8) :: a1, a2, a3, a4 - REAL (r8), DIMENSION(icube+1,icube+1) :: ang - REAL (r8), DIMENSION(icube+1) :: gp - - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - - !#ifdef DBG - REAL (r8) :: dbg1 !DBG - !#endif - - ! Recall that we are using equi-angular spherical gridding - ! Compute the angle between equiangular cubed sphere projection grid lines. - DO k = 1, icube+1 - gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1) - ENDDO - - DO k2=1,icube+1 - DO k1=1,icube+1 - ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2))) - ENDDO - ENDDO - - DO k2=1,icube - DO k1=1,icube - a1 = ang(k1 , k2 ) - a2 = pi - ang(k1+1, k2 ) - a3 = pi - ang(k1 , k2+1) - a4 = ang(k1+1, k2+1) - - ! area = r*r*(-2*pi+sum(interior angles)) - DA(k1,k2) = -2.0*pi+a1+a2+a3+a4 - ENDDO - ENDDO - - !#ifdef DBG - ! Only for debugging - test consistency - dbg1 = 0.0 !DBG - DO k2=1,icube - DO k1=1,icube - dbg1 = dbg1 + DA(k1,k2) !DBG - ENDDO - ENDDO - write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG - !#endif -END SUBROUTINE EquiangularAllAreas - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereRLLFromABP -! -! Description: -! Determine the lat lon coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! lon (OUT) - Calculated longitude -! lat (OUT) - Calculated latitude -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: lon, lat - ! Local variables - REAL (r8) :: xx, yy, zz, rotate_cube - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - rotate_cube = 0.0 - ! Convert to cartesian coordinates - CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - ! Convert back to lat lon - lat = ASIN(zz) - if (xx==0.0.and.yy==0.0) THEN - lon = 0.0 - else - lon = ATAN2(yy, xx) +rotate_cube - IF (lon<0.0) lon=lon+2.0*pi - IF (lon>2.0*pi) lon=lon-2.0*pi - end if -END SUBROUTINE CubedSphereRLLFromABP - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereXYZFromABP -! -! Description: -! Determine the Cartesian coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! xx (OUT) - Calculated x coordinate -! yy (OUT) - Calculated y coordinate -! zz (OUT) - Calculated z coordinate -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: xx, yy, zz - ! Local variables - REAL (r8) :: a1, b1, pm - REAL (r8) :: sx, sy, sz - - ! Convert to Cartesian coordinates - a1 = TAN(alpha) - b1 = TAN(beta) - - sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5) - sx = sz * a1 - sy = sz * b1 - ! Panel assignments - IF (ipanel == 6) THEN - yy = sx; xx = -sy; zz = sz - ELSEIF (ipanel == 5) THEN - yy = sx; xx = sy; zz = -sz - ELSEIF (ipanel == 1) THEN - yy = sx; zz = sy; xx = sz - ELSEIF (ipanel == 3) THEN - yy = -sx; zz = sy; xx = -sz - ELSEIF (ipanel == 2) THEN - xx = -sx; zz = sy; yy = sz - ELSEIF (ipanel == 4) THEN - xx = sx; zz = sy; yy = -sz - ELSE - WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP' - WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')' - STOP - ENDIF -END SUBROUTINE CubedSphereXYZFromABP - - diff --git a/tools/topo_tool/bin_to_cube/shr_kind_mod.F90 b/tools/topo_tool/bin_to_cube/shr_kind_mod.F90 deleted file mode 100644 index fc1ed8e94a..0000000000 --- a/tools/topo_tool/bin_to_cube/shr_kind_mod.F90 +++ /dev/null @@ -1,20 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - -END MODULE shr_kind_mod diff --git a/tools/topo_tool/cube_to_target/Makefile b/tools/topo_tool/cube_to_target/Makefile deleted file mode 100644 index 23d518cf03..0000000000 --- a/tools/topo_tool/cube_to_target/Makefile +++ /dev/null @@ -1,69 +0,0 @@ -EXEDIR = . -EXENAME = cube_to_target -RM = rm - -.SUFFIXES: -.SUFFIXES: .F90 .o - -FC = lf95 -DEBUG = FALSE - - -# Check for the NetCDF library and include directories -ifeq ($(LIB_NETCDF),$(null)) -LIB_NETCDF := /usr/local/lib -endif - -ifeq ($(INC_NETCDF),$(null)) -INC_NETCDF := /usr/local/include -endif - -# Determine platform -UNAMES := $(shell uname -s) -UNAMEM := $(findstring CRAY,$(shell uname -m)) - -#------------------------------------------------------------------------ -# LF95 -#------------------------------------------------------------------------ -# -# setenv LD_LIBRARY_PATH ${LD_LIBRARY_PATH}:/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib -# -ifeq ($(FC),lf95) -# -# Tramhill -# - INC_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/include - LIB_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib - - LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -lnetcdff -lcurl -lhdf5 -lhdf5_hl -mcmodel=medium - FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF) - ifeq ($(DEBUG),TRUE) -# FFLAGS += --chk aesu -Cpp --trace - FFLAGS += -g --chk a,e,s,u --pca - else - FFLAGS += -O - endif - -endif - - - -.F90.o: - $(FC) $(FFLAGS) $< - -#------------------------------------------------------------------------ -# Default rules and macros -#------------------------------------------------------------------------ - -OBJS := reconstruct.o remap.o cube_to_target.o shr_kind_mod.o - -$(EXEDIR)/$(EXENAME): $(OBJS) - $(FC) -o $@ $(OBJS) $(LDFLAGS) - -clean: - $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME) - -cube_to_target.o: shr_kind_mod.o remap.o reconstruct.o -remap.o: -reconstruct.o: remap.o -#reconstruct.o : shr_kind_mod.o diff --git a/tools/topo_tool/cube_to_target/README b/tools/topo_tool/cube_to_target/README deleted file mode 100644 index 134b6de4f9..0000000000 --- a/tools/topo_tool/cube_to_target/README +++ /dev/null @@ -1,20 +0,0 @@ -cube_to_target performs rigourous remapping of topo variables from cubed-sphere grid to -any target grid. In the process SGH is computed. - -Input files: - -1. USGS-topo-cube.nc (may be found here $CESMDATA/inputdata/atm/cam/hrtopo/USGS-topo-cube3000.nc) - - This is the topo data on a cubed-sphere (default is 3km cubed-sphere grid) - -2. target.nc (e.g., $CESMDATA/inputdata/atm/cam/grid-description/se/ne30np4_091226_pentagons.nc) - - This is a SCRIP/ESMF grid descriptor file for the target grid - -3. phis-smooth.nc - - (optional) The user may provide a smoothed PHIS field. The software then recomputes SGH to - account for the smoothing in the sub-grid-scale. - - - diff --git a/tools/topo_tool/cube_to_target/cube_to_target.F90 b/tools/topo_tool/cube_to_target/cube_to_target.F90 deleted file mode 100644 index 3f73f6a47b..0000000000 --- a/tools/topo_tool/cube_to_target/cube_to_target.F90 +++ /dev/null @@ -1,2008 +0,0 @@ -! -! DATE CODED: Nov 7, 2011 to Oct 15, 2012 -! DESCRIPTION: Remap topo data from cubed-sphere grid to target grid using rigorous remapping -! (Lauritzen, Nair and Ullrich, 2010, J. Comput. Phys.) -! -! Author: Peter Hjort Lauritzen (pel@ucar.edu), AMP/CGD/NESL/NCAR -! -program convterr - use shr_kind_mod, only: r8 => shr_kind_r8 - use reconstruct - implicit none -# include - - !************************************** - ! - ! USER SETTINGS BELOW - ! - !************************************** - ! - ! - ! if smoothed PHIS is available SGH needs to be recomputed to account for the sub-grid-scale - ! variability introduced by the smoothing - ! - logical :: lsmooth_terr = .FALSE. - ! - ! PHIS is smoothed by other software/dynamical core - ! - logical :: lexternal_smooth_terr = .FALSE. ! lexternal_smooth_terr = .FALSE. is NOT supported currently - ! - ! set PHIS=0.0 if LANDFRAC<0.01 - ! - logical :: lzero_out_ocean_point_phis = .FALSE. - ! - ! For internal smoothing (experimental at this point) - ! =================================================== - ! - ! if smoothing is internal (lexternal_smooth_terr=.FALSE.) choose coarsening factor - ! - ! recommendation: 2*(target resolution)/(0.03 degree) - ! - ! factor must be an even integer - ! - integer, parameter :: factor = 60 !coarse grid = 2.25 degrees - integer, parameter :: norder = 2 - integer, parameter :: nmono = 0 - integer, parameter :: npd = 1 - ! - !********************************************************************** - ! - ! END OF USER SETTINS BELOW - ! (do not edit beyond this point unless you know what you are doing!) - ! - !********************************************************************** - ! - integer :: im, jm, ncoarse - integer :: ncube !dimension of cubed-sphere grid - - real(r8), allocatable, dimension(:) :: landm_coslat, landfrac, terr, sgh30 - real(r8), allocatable, dimension(:) :: terr_coarse !for internal smoothing - - integer :: alloc_error,dealloc_error - integer :: i,j,n,k,index - integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile - integer ncid,status, dimlatid,dimlonid, landid, topoid ! for netCDF USGS data file - integer :: srcid,dstid, jm_dbg ! for netCDF weight file - integer, dimension(2) :: src_grid_dims ! for netCDF weight file - - integer :: dimid - - logical :: ldbg - real(r8), allocatable, dimension(:) :: lon , lat - real(r8), allocatable, dimension(:) :: lon_landm , lat_landm - real(r8), allocatable, dimension(:) :: area - integer :: im_landm, jm_landm - integer :: lonid, latid, phisid - ! - ! constants - ! - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: pih = 0.50*pi - REAL (r8), PARAMETER :: deg2rad = pi/180.0 - - real(r8) :: wt,dlat - integer :: ipanel,icube,jcube - real(r8), allocatable, dimension(:,:,:) :: weight,terr_cube,landfrac_cube,sgh30_cube - real(r8), allocatable, dimension(:,:,:) :: landm_coslat_cube - integer, allocatable, dimension(:,:) :: idx,idy,idp - integer :: npatch, isub,jsub, itmp, iplm1,jmin,jmax - real(r8) :: sum,dx,scale,dmax,arad,jof,term,s1,c1,clon,iof,dy,s2,c2,dist - ! - ! for linear interpolation - ! - real(r8) :: lambda,theta,wx,wy,offset - integer :: ilon,ilat,ip1,jp1 - ! - ! variable for regridding - ! - integer :: src_grid_dim ! for netCDF weight file - integer :: n_a,n_b,n_s,n_aid,n_bid,n_sid - integer :: count - real(r8), allocatable, dimension(:) :: landfrac_target, terr_target, sgh30_target, sgh_target - real(r8), allocatable, dimension(:) :: landm_coslat_target, area_target - ! - ! this is only used if target grid is a lat-lon grid - ! - integer , parameter :: im_target = 360 , jm_target = 180 - ! - ! this is only used if target grid is not a lat-lon grid - ! - real(r8), allocatable, dimension(:) :: lon_target, lat_target - ! - ! new - ! - integer :: ntarget, ntarget_id, ncorner, ncorner_id, nrank, nrank_id - integer :: ntarget_smooth - real(r8), allocatable, dimension(:,:):: target_corner_lon, target_corner_lat - real(r8), allocatable, dimension(:) :: target_center_lon, target_center_lat, target_area - integer :: ii,ip,jx,jy,jp - real(r8), dimension(:), allocatable :: xcell, ycell, xgno, ygno - real(r8), dimension(:), allocatable :: gauss_weights,abscissae - integer, parameter :: ngauss = 3 - integer :: jmax_segments,jall - real(r8) :: tmp - - real(r8), allocatable, dimension(:,:) :: weights_all - integer , allocatable, dimension(:,:) :: weights_eul_index_all - integer , allocatable, dimension(:) :: weights_lgr_index_all - integer :: ix,iy - ! - ! volume of topography - ! - real(r8) :: vol_target, vol_target_un, area_target_total,vol_source,vol_tmp - integer :: nlon,nlon_smooth,nlat,nlat_smooth - logical :: ltarget_latlon,lpole - real(r8), allocatable, dimension(:,:) :: terr_smooth - ! - ! for internal filtering - ! - real(r8), allocatable, dimension(:,:) :: weights_all_coarse - integer , allocatable, dimension(:,:) :: weights_eul_index_all_coarse - integer , allocatable, dimension(:) :: weights_lgr_index_all_coarse - real(r8), allocatable, dimension(:) :: area_target_coarse - real(r8), allocatable, dimension(:,:) :: da_coarse,da - real(r8), allocatable, dimension(:,:) :: recons,centroids - integer :: nreconstruction - - integer :: jmax_segments_coarse,jall_coarse,ncube_coarse - real(r8) :: all_weights - - ! - ! turn extra debugging on/off - ! - ldbg = .FALSE. - - nreconstruction = 1 - ! - !********************************************************* - ! - ! read in target grid - ! - !********************************************************* - ! - status = nf_open('target.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'grid_size', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, ntarget) - WRITE(*,*) "dimension of target grid: ntarget=",ntarget - - status = NF_INQ_DIMID(ncid, 'grid_corners', ncorner_id) - status = NF_INQ_DIMLEN(ncid, ncorner_id, ncorner) - WRITE(*,*) "maximum number of corners: ncorner=",ncorner - - status = NF_INQ_DIMID(ncid, 'grid_rank', nrank_id);status = NF_INQ_DIMLEN(ncid, nrank_id, nrank) - WRITE(*,*) "grid rank: nrank=",nrank - IF (nrank==2) THEN - WRITE(*,*) "target grid is a lat-lon grid" - ltarget_latlon = .TRUE. - status = NF_INQ_DIMID(ncid, 'nlon', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon) - status = NF_INQ_DIMID(ncid, 'nlat', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat) - status = NF_INQ_DIMID(ncid, 'lpole', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, lpole) - WRITE(*,*) "nlon=",nlon,"nlat=",nlat - IF (lpole) THEN - WRITE(*,*) "center of most Northern grid cell is lat=90; similarly for South pole" - ELSE - WRITE(*,*) "center of most Northern grid cell is NOT lat=90; similarly for South pole" - END IF - ELSE IF (nrank==1) THEN - ltarget_latlon = .FALSE. - ELSE - WRITE(*,*) "nrank out of range",nrank - STOP - ENDIF - - allocate ( target_corner_lon(ncorner,ntarget),stat=alloc_error) - allocate ( target_corner_lat(ncorner,ntarget),stat=alloc_error) - - status = NF_INQ_VARID(ncid, 'grid_corner_lon', lonid) - status = NF_GET_VAR_DOUBLE(ncid, lonid,target_corner_lon) - IF (maxval(target_corner_lon)>10.0) target_corner_lon = deg2rad*target_corner_lon - - status = NF_INQ_VARID(ncid, 'grid_corner_lat', latid) - status = NF_GET_VAR_DOUBLE(ncid, latid,target_corner_lat) - IF (maxval(target_corner_lat)>10.0) target_corner_lat = deg2rad*target_corner_lat - ! - ! for writing remapped data on file at the end of the program - ! - allocate ( target_center_lon(ntarget),stat=alloc_error) - allocate ( target_center_lat(ntarget),stat=alloc_error) - allocate ( target_area (ntarget),stat=alloc_error)!dbg - - status = NF_INQ_VARID(ncid, 'grid_center_lon', lonid) - status = NF_GET_VAR_DOUBLE(ncid, lonid,target_center_lon) - - status = NF_INQ_VARID(ncid, 'grid_center_lat', latid) - status = NF_GET_VAR_DOUBLE(ncid, latid,target_center_lat) - - status = NF_INQ_VARID(ncid, 'grid_area', latid) - status = NF_GET_VAR_DOUBLE(ncid, latid,target_area) - - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - !**************************************************** - ! - ! get dimension of cubed-sphere grid - ! - !**************************************************** - ! - WRITE(*,*) "get dimension of cubed-sphere data from file" - status = nf_open('USGS-topo-cube.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'grid_size', dimid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimid, n) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - ncube = INT(SQRT(DBLE(n/6))) - WRITE(*,*) "cubed-sphere dimension: ncube = ",ncube - WRITE(*,*) "average grid-spacing at the Equator (degrees):" ,90.0/ncube - - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - !**************************************************** - ! - ! compute weights for remapping - ! - !**************************************************** - ! - jall = ncube*ncube*12*10 !anticipated number of weights (cab be tweaked) - jmax_segments = 100000 !can be tweaked - - allocate (weights_all(jall,nreconstruction),stat=alloc_error ) - allocate (weights_eul_index_all(jall,3),stat=alloc_error ) - allocate (weights_lgr_index_all(jall),stat=alloc_error ) - - CALL overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,& - jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction) - ! - !**************************************************** - ! - ! read cubed-sphere 3km data - ! - !**************************************************** - ! - WRITE(*,*) "read cubed-sphere 3km data from file" - status = nf_open('USGS-topo-cube.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'grid_size', dimid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimid, n) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - ncube = INT(SQRT(DBLE(n/6))) - WRITE(*,*) "cubed-sphere dimension, ncube: ",ncube - - allocate ( landm_coslat(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'LANDM_COSLAT', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,landm_coslat) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of landm_coslat",MINVAL(landm_coslat),MAXVAL(landm_coslat) - ! - ! read LANDFRAC - ! - allocate ( landfrac(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'LANDFRAC', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,landfrac) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of landfrac",MINVAL(landfrac),MAXVAL(landfrac) - ! - ! read terr - ! - allocate ( terr(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'terr', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,terr) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of terr",MINVAL(terr),MAXVAL(terr) - ! - ! - ! - allocate ( sgh30(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'SGH30', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,sgh30) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of sgh30",MINVAL(sgh30),MAXVAL(sgh30) - print *,"close file" - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - - WRITE(*,*) 'done reading in LANDM_COSLAT data from netCDF file' - ! - !********************************************************* - ! - ! do actual remapping - ! - !********************************************************* - ! - allocate (terr_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr_target' - stop - end if - allocate (landfrac_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac_target' - stop - end if - allocate (landm_coslat_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac_target' - stop - end if - allocate (sgh30_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for sgh30_target' - stop - end if - allocate (area_target(ntarget),stat=alloc_error ) - terr_target = 0.0 - landfrac_target = 0.0 - sgh30_target = 0.0 - landm_coslat_target = 0.0 - area_target = 0.0 - - tmp = 0.0 - do count=1,jall - i = weights_lgr_index_all(count) - wt = weights_all(count,1) - area_target (i) = area_target(i) + wt - end do - - do count=1,jall - i = weights_lgr_index_all(count) - - ix = weights_eul_index_all(count,1) - iy = weights_eul_index_all(count,2) - ip = weights_eul_index_all(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix - - wt = weights_all(count,1) - - terr_target (i) = terr_target (i) + wt*terr (ii)/area_target(i) - landfrac_target (i) = landfrac_target (i) + wt*landfrac (ii)/area_target(i) - landm_coslat_target(i) = landm_coslat_target(i) + wt*landm_coslat(ii)/area_target(i) - sgh30_target (i) = sgh30_target (i) + wt*sgh30 (ii)/area_target(i) - - tmp = tmp+wt*terr(ii) - end do - - - write(*,*) "tmp", tmp - WRITE(*,*) "max difference between target grid area and remapping software area",& - MAXVAL(target_area-area_target) - - do count=1,ntarget - if (terr_target(count)>8848.0) then - ! - ! max height is higher than Mount Everest - ! - write(*,*) "FATAL error: max height is higher than Mount Everest!" - write(*,*) "terr_target",count,terr_target(count) - write(*,*) "(lon,lat) locations of vertices of cell with excessive max height::" - do i=1,ncorner - write(*,*) target_corner_lon(i,count),target_corner_lat(i,count) - end do - STOP - else if (terr_target(count)<-423.0) then - ! - ! min height is lower than Dead Sea - ! - write(*,*) "FATAL error: min height is lower than Dead Sea!" - write(*,*) "terr_target",count,terr_target(count) - write(*,*) "(lon,lat) locations of vertices of cell with excessive min height::" - do i=1,ncorner - write(*,*) target_corner_lon(i,count),target_corner_lat(i,count) - end do - STOP - else - - end if - end do - WRITE(*,*) "Elevation data passed min/max consistency check!" - WRITE(*,*) - - WRITE(*,*) "min/max of unsmoothed terr_target : ",MINVAL(terr_target ),MAXVAL(terr_target ) - WRITE(*,*) "min/max of landfrac_target : ",MINVAL(landfrac_target),MAXVAL(landfrac_target) - WRITE(*,*) "min/max of landm_coslat_target : ",& - MINVAL(landm_coslat_target),MAXVAL(landm_coslat_target) - WRITE(*,*) "min/max of var30_target : ",MINVAL(sgh30_target ),MAXVAL(sgh30_target ) - ! - ! compute mean height (globally) of topography about sea-level for target grid unfiltered elevation - ! - vol_target_un = 0.0 - area_target_total = 0.0 - DO i=1,ntarget - area_target_total = area_target_total+area_target(i) - vol_target_un = vol_target_un+terr_target(i)*area_target(i) - END DO - WRITE(*,*) "mean height (globally) of topography about sea-level for target grid unfiltered elevation",& - vol_target_un/area_target_total - - ! - ! diagnostics - ! - vol_source = 0.0 - allocate ( dA(ncube,ncube),stat=alloc_error ) - CALL EquiangularAllAreas(ncube, dA) - DO jp=1,6 - DO jy=1,ncube - DO jx=1,ncube - ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx - vol_source = vol_source+terr(ii)*dA(jx,jy) - END DO - END DO - END DO - WRITE(*,*) "volume of input cubed-sphere terrain :",vol_source - WRITE(*,*) "average elevation of input cubed-sphere terrain:",vol_source/(4.0*pi) - - DEALLOCATE(dA) - ! - ! - ! - allocate (sgh_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for sgh_target' - stop - end if - ! - ! compute variance with respect to cubed-sphere data - ! - WRITE(*,*) "compute variance with respect to 3km cubed-sphere data: SGH" - - IF (lsmooth_terr) THEN - WRITE(*,*) "smoothing PHIS" - IF (lexternal_smooth_terr) THEN - WRITE(*,*) "using externally generated smoothed topography" - - status = nf_open('phis-smooth.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - ! - IF (.NOT.ltarget_latlon) THEN - ! - !********************************************************* - ! - ! read in smoothed topography - ! - !********************************************************* - ! - status = NF_INQ_DIMID (ncid, 'ncol', ntarget_id ) - status = NF_INQ_DIMLEN(ncid, ntarget_id , ntarget_smooth) - IF (ntarget.NE.ntarget_smooth) THEN - WRITE(*,*) "mismatch in smoothed data-set and target grid specification" - WRITE(*,*) ntarget, ntarget_smooth - STOP - END IF - status = NF_INQ_VARID(ncid, 'PHIS', phisid) - ! - ! overwrite terr_target with smoothed version - ! - status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_target) - terr_target = terr_target/9.80616 - ELSE - ! - ! read in smoothed lat-lon topography - ! - status = NF_INQ_DIMID(ncid, 'lon', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon_smooth) - status = NF_INQ_DIMID(ncid, 'lat', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat_smooth) - IF (nlon.NE.nlon_smooth.OR.nlat.NE.nlat_smooth) THEN - WRITE(*,*) "smoothed topography dimensions do not match target grid dimensions" - WRITE(*,*) "target grid : nlon ,nlat =",nlon,nlat - WRITE(*,*) "smoothed topo: nlon_smooth,nlat_smooth =",nlon_smooth,nlat_smooth - STOP - END IF - ALLOCATE(terr_smooth(nlon_smooth,nlat_smooth),stat=alloc_error) - status = NF_INQ_VARID(ncid, 'PHIS', phisid) - status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_smooth) - ! - ! overwrite terr_target with smoothed version - ! - ii=1 - DO j=1,nlat - DO i=1,nlon - terr_target(ii) = terr_smooth(i,j)/9.80616 - ii=ii+1 - END DO - END DO - DEALLOCATE(terr_smooth) - END IF - ELSE - WRITE(*,*) "unstested software - uncomment this line of you know what you are doing!" - STOP - ! - !***************************************************** - ! - ! smoothing topography internally - ! - !***************************************************** - ! - WRITE(*,*) "internally smoothing orography" - ! CALL smooth(terr_target,ntarget,target_corner_lon,target_corner_lat) - ! - ! smooth topography internally - ! - ncoarse = n/(factor*factor) - ! - ! - ! - ncube_coarse = ncube/factor - WRITE(*,*) "resolution of coarse grid", 90.0/ncube_coarse - allocate ( terr_coarse(ncoarse),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - WRITE(*,*) "coarsening" - allocate ( dA_coarse(ncube_coarse,ncube_coarse),stat=alloc_error ) - CALL coarsen(terr,terr_coarse,factor,n,dA_coarse) - ! - ! - ! - vol_tmp = 0.0 - DO jp=1,6 - DO jy=1,ncube_coarse - DO jx=1,ncube_coarse - ii = (jp-1)*ncube_coarse*ncube_coarse+(jy-1)*ncube_coarse+jx - vol_tmp = vol_tmp+terr_coarse(ii)*dA_coarse(jx,jy) - END DO - END DO - END DO - WRITE(*,*) "volume of coarsened cubed-sphere terrain :",vol_source - WRITE(*,*) "difference between coarsened cubed-sphere data and input cubed-sphere data",& - vol_tmp-vol_source - - - - WRITE(*,*) "done coarsening" - - nreconstruction = 1 - IF (norder>1) THEN - IF (norder == 2) THEN - nreconstruction = 3 - ELSEIF (norder == 3) THEN - nreconstruction = 6 - END IF - ALLOCATE(recons (nreconstruction, ncoarse), STAT=status) - ALLOCATE(centroids(nreconstruction, ncoarse), STAT=status) - CALL get_reconstruction(terr_coarse,norder, nmono, recons, npd,da_coarse,& - ncube_coarse+1,nreconstruction,centroids) - SELECT CASE (nmono) - CASE (0) - WRITE(*,*) "coarse grid reconstructions are not filtered with shape-preesrving filter" - CASE (1) - WRITE(*,*) "coarse grid reconstructions are filtered with shape-preserving filter" - CASE DEFAULT - WRITE(*,*) "nmono out of range: ",nmono - STOP - END SELECT - SELECT CASE (0) - CASE (0) - WRITE(*,*) "coarse grid reconstructions are not filtered with positive definite filter" - CASE (1) - WRITE(*,*) "coarse grid reconstructions filtered with positive definite filter" - CASE DEFAULT - WRITE(*,*) "npd out of range: ",npd - STOP - END SELECT - END IF - - jall_coarse = (ncube*ncube*12) !anticipated number of weights - jmax_segments_coarse = jmax_segments!/factor ! - WRITE(*,*) "anticipated",jall_coarse - allocate (weights_all_coarse(jall_coarse,nreconstruction),stat=alloc_error ) - allocate (weights_eul_index_all_coarse(jall_coarse,3),stat=alloc_error ) - allocate (weights_lgr_index_all_coarse(jall_coarse),stat=alloc_error ) - ! - ! - ! - CALL overlap_weights(weights_lgr_index_all_coarse,weights_eul_index_all_coarse,weights_all_coarse,& - jall_coarse,ncube_coarse,ngauss,ntarget,ncorner,jmax_segments_coarse,target_corner_lon,& - target_corner_lat,nreconstruction) - WRITE(*,*) "MIN/MAX of area-weight [0:1]: ",& - MINVAL(weights_all_coarse(:,1)),MAXVAL(weights_all_coarse(:,1)) - ! - ! compute new weights - ! - - ! - ! do mapping - ! - terr_target = 0.0 - tmp = 0.0 - allocate ( area_target_coarse(ntarget),stat=alloc_error) - all_weights = 0.0 - area_target_coarse = 0.0 - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - wt = weights_all_coarse(count,1) - area_target_coarse (i) = area_target_coarse(i) + wt - all_weights = all_weights+wt - end do - WRITE(*,*) "sum of all weights (coarse to target) minus area of sphere : ",all_weights-4.0*pi - WRITE(*,*) "MIN/MAX of area_target_coarse [0:1]:",& - MINVAL(area_target_coarse),MAXVAL(area_target_coarse) - IF (norder==1) THEN - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - - ix = weights_eul_index_all_coarse(count,1) - iy = weights_eul_index_all_coarse(count,2) - ip = weights_eul_index_all_coarse(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix - - wt = weights_all_coarse(count,1) - - terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i) - tmp = tmp+wt*terr_coarse(ii) - end do - ELSE IF (norder==2) THEN - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - IF (i>jall_coarse.OR.i<1) THEN - WRITE(*,*) i,jall_coarse - STOP - END IF - ix = weights_eul_index_all_coarse(count,1) - iy = weights_eul_index_all_coarse(count,2) - ip = weights_eul_index_all_coarse(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix - - terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(& - ! - ! all constant terms - ! - terr_coarse(ii) & - - recons(1,ii)*centroids(1,ii) & - - recons(2,ii)*centroids(2,ii) & - ! - ! + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))& - ! + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))& - ! - ! + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))& - )+& - ! - ! linear terms - ! - weights_all_coarse(count,2)*(& - - recons(1,ii)& - - ! - recons(3,ii)*2.0*centroids(1,ii)& - ! - recons(5,ii)* centroids(2,ii)& - )+& - ! - weights_all_coarse(count,3)*(& - recons(2,ii)& - ! - ! - recons(4,ii)*2.0*centroids(2,ii)& - ! - recons(5,ii)* centroids(1,ii)& - )& - ! - ! quadratic terms - ! - ! weights_all_coarse(count,4)*recons(3,ii)+& - ! weights_all_coarse(count,5)*recons(4,ii)+& - ! weights_all_coarse(count,6)*recons(5,ii) - )/area_target_coarse(i) - end do - DEALLOCATE(centroids) - DEALLOCATE(recons) - DEALLOCATE(weights_all_coarse) - - ELSE IF (norder==3) THEN - ! recons(4,:) = 0.0 - ! recons(5,:) = 0.0 - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - IF (i>jall_coarse.OR.i<1) THEN - WRITE(*,*) i,jall_coarse - STOP - END IF - ix = weights_eul_index_all_coarse(count,1) - iy = weights_eul_index_all_coarse(count,2) - ip = weights_eul_index_all_coarse(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix - - ! terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i) - - ! WRITE(*,*) count,area_target_coarse(i) - ! terr_target(i) = terr_target(i) + area_target_coarse(i) - ! - terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(& - - - ! centroids(5,ii))/area_target_coarse(i)) - ! centroids(1,ii)/area_target_coarse(i)) - ! /area_target_coarse(i)) - - - - - ! - ! all constant terms - ! - terr_coarse(ii) & - - recons(1,ii)*centroids(1,ii) & - - recons(2,ii)*centroids(2,ii) & - ! - + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))& - + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))& - ! - + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))& - )+& - ! - ! linear terms - ! - weights_all_coarse(count,2)*(& - - recons(1,ii)& - - - recons(3,ii)*2.0*centroids(1,ii)& - - recons(5,ii)* centroids(2,ii)& - )+& - ! - weights_all_coarse(count,3)*(& - recons(2,ii)& - ! - - recons(4,ii)*2.0*centroids(2,ii)& - - recons(5,ii)* centroids(1,ii)& - )+& - ! - ! quadratic terms - ! - weights_all_coarse(count,4)*recons(3,ii)+& - weights_all_coarse(count,5)*recons(4,ii)+& - weights_all_coarse(count,6)*recons(5,ii))/area_target_coarse(i) - end do - DEALLOCATE(centroids) - DEALLOCATE(recons) - DEALLOCATE(weights_all_coarse) - END IF - DEALLOCATE(area_target_coarse) - WRITE(*,*) "done smoothing" - END IF - ! - ! compute mean height (globally) of topography about sea-level for target grid filtered elevation - ! - vol_target = 0.0 - DO i=1,ntarget - vol_target = vol_target+terr_target(i)*area_target(i) - ! if (ABS(area_target(i)-area_target_coarse(i))>0.000001) THEN - ! WRITE(*,*) "xxx",area_target(i),area_target_coarse(i),area_target(i)-area_target_coarse(i) - ! STOP - ! END IF - END DO - WRITE(*,*) "mean height (globally) of topography about sea-level for target grid filtered elevation",& - vol_target/area_target_total - WRITE(*,*) "percentage change in mean height between filtered and unfiltered elevations",& - 100.0*(vol_target-vol_target_un)/vol_target_un - WRITE(*,*) "percentage change in mean height between input cubed-sphere and unfiltered elevations",& - 100.0*(vol_source-vol_target_un)/vol_source - - END IF - ! - ! Done internal smoothing - ! - WRITE(*,*) "min/max of terr_target : ",MINVAL(terr_target),MAXVAL(terr_target) - - if (lzero_out_ocean_point_phis) then - WRITE(*,*) "if ocean mask PHIS=0.0" - end if - - - sgh_target=0.0 - do count=1,jall - i = weights_lgr_index_all(count)!! - ! - ix = weights_eul_index_all(count,1) - iy = weights_eul_index_all(count,2) - ip = weights_eul_index_all(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - - wt = weights_all(count,1) - - if (lzero_out_ocean_point_phis.AND.landfrac_target(i).lt.0.01_r8) then - terr_target(i) = 0.0_r8 !5*terr_target(i) - end if - sgh_target(i) = sgh_target(i)+wt*((terr_target(i)-terr(ii))**2)/area_target(i) - end do - - - - ! - ! zero out small values - ! - DO i=1,ntarget - IF (landfrac_target(i)<.001_r8) landfrac_target(i) = 0.0 - IF (sgh_target(i)<0.5) sgh_target(i) = 0.0 - IF (sgh30_target(i)<0.5) sgh30_target(i) = 0.0 - END DO - sgh_target = SQRT(sgh_target) - sgh30_target = SQRT(sgh30_target) - WRITE(*,*) "min/max of sgh_target : ",MINVAL(sgh_target),MAXVAL(sgh_target) - WRITE(*,*) "min/max of sgh30_target : ",MINVAL(sgh30_target),MAXVAL(sgh30_target) - - DEALLOCATE(terr,weights_all,weights_eul_index_all,landfrac,landm_coslat) - - - IF (ltarget_latlon) THEN - CALL wrtncdf_rll(nlon,nlat,lpole,ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,& - landm_coslat_target,target_center_lon,target_center_lat,.true.) - ELSE - CALL wrtncdf_unstructured(ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,& - landm_coslat_target,target_center_lon,target_center_lat) - END IF - DEALLOCATE(terr_target,landfrac_target,sgh30_target,sgh_target,landm_coslat_target) - -end program convterr - -! -! -! -subroutine wrtncdf_unstructured(n,terr,landfrac,sgh,sgh30,landm_coslat,lon,lat) - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - -# include - - ! - ! Dummy arguments - ! - integer, intent(in) :: n - real(r8),dimension(n) , intent(in) :: terr, landfrac,sgh,sgh30,lon, lat, landm_coslat - ! - ! Local variables - ! - character (len=64) :: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: terrid,nid - integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid - integer :: status ! return value for error control of netcdf routin - integer :: i,j - integer, dimension(2) :: nc_lat_vid,nc_lon_vid - character (len=8) :: datestring - integer :: nc_gridcorn_id, lat_vid, lon_vid - - real(r8), parameter :: fillvalue = 1.d36 - - fout='new-topo-file.nc' - ! - ! Create NetCDF file for output - ! - print *,"Create NetCDF file for output" - status = nf_create (fout, NF_64BIT_OFFSET , foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create dimensions for output - ! - status = nf_def_dim (foutid, 'ncol', n, nid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create variable for output - ! - print *,"Create variable for output" - status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 1, nid, terrid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 1, nid, landfracid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'SGH', NF_DOUBLE, 1, nid, sghid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 1, nid, sgh30id) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 1, nid, landm_coslatid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, nid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, nid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - - ! - ! Create attributes for output variables - ! - status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential') - status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2') - status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue) - ! status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from USGS 30-sec data') - - status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sghid, 'long_name' , 48, & - 'standard deviation of 3km cubed-sphere elevation and target grid elevation') - status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm') - ! status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, & - 'standard deviation of 30s elevation from 3km cubed-sphere cell average height') - status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm') - ! status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction') - status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction') - ! status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data') - - - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 50, 'USGS 30-sec dataset binned to ncube3000 (cube-sphere) grid') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - - ! - ! End define mode for output file - ! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Write variable for output - ! - print*,"writing terrain data",MINVAL(terr),MAXVAL(terr) - status = nf_put_var_double (foutid, terrid, terr*9.80616) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing terrain data" - - print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac) - status = nf_put_var_double (foutid, landfracid, landfrac) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing landfrac data" - - print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh) - status = nf_put_var_double (foutid, sghid, sgh) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh data" - - print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30) - status = nf_put_var_double (foutid, sgh30id, sgh30) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - - print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat) - status = nf_put_var_double (foutid, landm_coslatid, landm_coslat) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - ! - print*,"writing lat data" - status = nf_put_var_double (foutid, latvid, lat) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lat data" - - print*,"writing lon data" - status = nf_put_var_double (foutid, lonvid, lon) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lon data" - ! - ! Close output file - ! - print *,"close file" - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -end subroutine wrtncdf_unstructured -! -!************************************************************** -! -! if target grid is lat-lon output structured -! -!************************************************************** -! -subroutine wrtncdf_rll(nlon,nlat,lpole,n,terr_in,landfrac_in,sgh_in,sgh30_in,landm_coslat_in,lon,lat,lprepare_fv_smoothing_routine) - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - -# include - - ! - ! Dummy arguments - ! - integer, intent(in) :: n,nlon,nlat - ! - ! lprepare_fv_smoothing_routine is to make a NetCDF file that can be used with the CAM-FV smoothing software - ! - logical , intent(in) :: lpole,lprepare_fv_smoothing_routine - real(r8),dimension(n) , intent(in) :: terr_in, landfrac_in,sgh_in,sgh30_in,lon, lat, landm_coslat_in - ! - ! Local variables - ! - character (len=32) :: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: terrid,nid - integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid - integer :: status ! return value for error control of netcdf routin - integer :: i,j - integer, dimension(2) :: nc_lat_vid,nc_lon_vid - character (len=8) :: datestring - integer :: nc_gridcorn_id, lat_vid, lon_vid - real(r8), parameter :: fillvalue = 1.d36 - real(r8) :: ave - - real(r8),dimension(nlon) :: lonar ! longitude array - real(r8),dimension(nlat) :: latar ! latitude array - - integer, dimension(2) :: htopodim,landfdim,sghdim,sgh30dim,landmcoslatdim - real(r8),dimension(n) :: terr, landfrac,sgh,sgh30,landm_coslat - - IF (nlon*nlat.NE.n) THEN - WRITE(*,*) "inconsistent input for wrtncdf_rll" - STOP - END IF - ! - ! we assume that the unstructured layout of the lat-lon grid is ordered in latitude rows, that is, - ! unstructured index n is given by - ! - ! n = (j-1)*nlon+i - ! - ! where j is latitude index and i longitude index - ! - do i = 1,nlon - lonar(i)= lon(i) - enddo - do j = 1,nlat - latar(j)= lat((j-1)*nlon+1) - enddo - - terr = terr_in - sgh=sgh_in - sgh30 =sgh30_in - landfrac = landfrac_in - landm_coslat = landm_coslat_in - - if (lpole) then - write(*,*) "average pole control volume" - ! - ! North pole - terr - ! - ave = 0.0 - do i=1,nlon - ave = ave + terr_in(i) - end do - terr(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + terr_in(i) - end do - terr(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - sgh - ! - ave = 0.0 - do i=1,nlon - ave = ave + sgh_in(i) - end do - sgh(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + sgh_in(i) - end do - sgh(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - sgh30 - ! - ave = 0.0 - do i=1,nlon - ave = ave + sgh30_in(i) - end do - sgh30(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + sgh30_in(i) - end do - sgh30(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - landfrac - ! - ave = 0.0 - do i=1,nlon - ave = ave + landfrac_in(i) - end do - landfrac(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + landfrac_in(i) - end do - landfrac(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - landm_coslat - ! - ave = 0.0 - do i=1,nlon - ave = ave + landm_coslat_in(i) - end do - landm_coslat(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + landm_coslat_in(i) - end do - landm_coslat(n-(nlon+1):n) = ave/DBLE(nlon) - end if - - - fout='final.nc' - ! - ! Create NetCDF file for output - ! - print *,"Create NetCDF file for output" - status = nf_create (fout, NF_64BIT_OFFSET , foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create dimensions for output - ! - print *,"Create dimensions for output" - status = nf_def_dim (foutid, 'lon', nlon, lonid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'lat', nlat, latid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create variable for output - ! - print *,"Create variable for output" - - htopodim(1)=lonid - htopodim(2)=latid - - if (lprepare_fv_smoothing_routine) then - status = nf_def_var (foutid,'htopo', NF_DOUBLE, 2, htopodim, terrid) - else - status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 2, htopodim, terrid) - end if - if (status .ne. NF_NOERR) call handle_err(status) - - landfdim(1)=lonid - landfdim(2)=latid - - if (lprepare_fv_smoothing_routine) then - status = nf_def_var (foutid,'ftopo', NF_DOUBLE, 2, landfdim, landfracid) - else - status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 2, landfdim, landfracid) - end if - - if (status .ne. NF_NOERR) call handle_err(status) - - sghdim(1)=lonid - sghdim(2)=latid - - status = nf_def_var (foutid,'SGH', NF_DOUBLE, 2, sghdim, sghid) - if (status .ne. NF_NOERR) call handle_err(status) - - sgh30dim(1)=lonid - sgh30dim(2)=latid - - status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 2, sgh30dim, sgh30id) - if (status .ne. NF_NOERR) call handle_err(status) - - landmcoslatdim(1)=lonid - landmcoslatdim(2)=latid - - status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 2, landmcoslatdim, landm_coslatid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - - ! - ! Create attributes for output variables - ! - status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential') - status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2') - status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from ncube3000 data') - status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue) - - - status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sghid, 'long_name' , 48, & - 'standard deviation of 3km cubed-sphere elevation and target grid elevation') - status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm') - status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, & - 'standard deviation of 30s elevation from 3km cubed-sphere cell average height') - status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm') - status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction') - status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction') - status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data') - - - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - - ! - ! End define mode for output file - ! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Write variable for output - ! - print*,"writing terrain data",MINVAL(terr),MAXVAL(terr) - if (lprepare_fv_smoothing_routine) then - status = nf_put_var_double (foutid, terrid, terr) - else - status = nf_put_var_double (foutid, terrid, terr*9.80616) - end if - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing terrain data" - - print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac) - status = nf_put_var_double (foutid, landfracid, landfrac) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing landfrac data" - - print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh) - status = nf_put_var_double (foutid, sghid, sgh) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh data" - - print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30) - status = nf_put_var_double (foutid, sgh30id, sgh30) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - - print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat) - status = nf_put_var_double (foutid, landm_coslatid, landm_coslat) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - ! - print*,"writing lat data" - status = nf_put_var_double (foutid, latvid, latar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lat data" - - print*,"writing lon data" - status = nf_put_var_double (foutid, lonvid, lonar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lon data" - ! - ! Close output file - ! - print *,"close file" - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -end subroutine wrtncdf_rll -!************************************************************************ -!!handle_err -!************************************************************************ -! -!!ROUTINE: handle_err -!!DESCRIPTION: error handler -!-------------------------------------------------------------------------- - -subroutine handle_err(status) - - implicit none - -# include - - integer status - - if (status .ne. nf_noerr) then - print *, nf_strerror(status) - stop 'Stopped' - endif - -end subroutine handle_err - - -SUBROUTINE coarsen(f,fcoarse,nf,n,dA_coarse) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - REAL (R8), DIMENSION(n) , INTENT(IN) :: f - REAL (R8), DIMENSION(n/nf), INTENT(OUT) :: fcoarse - INTEGER, INTENT(in) :: n,nf - REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf),INTENT(OUT) :: dA_coarse - !must be an even number - ! - ! local workspace - ! - ! ncube = INT(SQRT(DBLE(n/6))) - - REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6))),INT(SQRT(DBLE(n/6)))):: dA - REAL (R8) :: sum, sum_area,tmp - INTEGER :: jx,jy,jp,ii,ii_coarse,coarse_ncube,ncube - INTEGER :: jx_coarse,jy_coarse,jx_s,jy_s - - - ! REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf) :: dAtmp - - ncube = INT(SQRT(DBLE(n/6))) - coarse_ncube = ncube/nf - - IF (ABS(DBLE(ncube)/DBLE(nf)-coarse_ncube)>0.000001) THEN - WRITE(*,*) "ncube/nf must be an integer" - WRITE(*,*) "ncube and nf: ",ncube,nf - STOP - END IF - - da_coarse = 0.0 - - WRITE(*,*) "compute all areas" - CALL EquiangularAllAreas(ncube, dA) - ! CALL EquiangularAllAreas(coarse_ncube, dAtmp)!dbg - tmp = 0.0 - DO jp=1,6 - DO jy_coarse=1,coarse_ncube - DO jx_coarse=1,coarse_ncube - ! - ! inner loop - ! - sum = 0.0 - sum_area = 0.0 - DO jy_s=1,nf - jy = (jy_coarse-1)*nf+jy_s - DO jx_s=1,nf - jx = (jx_coarse-1)*nf+jx_s - ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx - sum = sum +f(ii)*dA(jx,jy) - sum_area = sum_area+dA(jx,jy) - ! WRITE(*,*) "jx,jy",jx,jy - END DO - END DO - tmp = tmp+sum_area - da_coarse(jx_coarse,jy_coarse) = sum_area - ! WRITE(*,*) "jx_coarse,jy_coarse",jx_coarse,jy_coarse,& - ! da_coarse(jx_coarse,jy_coarse)-datmp(jx_coarse,jy_coarse) - ii_coarse = (jp-1)*coarse_ncube*coarse_ncube+(jy_coarse-1)*coarse_ncube+jx_coarse - fcoarse(ii_coarse) = sum/sum_area - END DO - END DO - END DO - WRITE(*,*) "coarsened surface area",tmp-4.0*3.141592654 -END SUBROUTINE COARSEN - -SUBROUTINE overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,& - jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction) - use shr_kind_mod, only: r8 => shr_kind_r8 - use remap - IMPLICIT NONE - - - INTEGER, INTENT(INOUT) :: jall !anticipated number of weights - INTEGER, INTENT(IN) :: ncube, ngauss, ntarget, jmax_segments, ncorner, nreconstruction - - INTEGER, DIMENSION(jall,3), INTENT(OUT) :: weights_eul_index_all - REAL(R8), DIMENSION(jall,nreconstruction) , INTENT(OUT) :: weights_all - INTEGER, DIMENSION(jall) , INTENT(OUT) :: weights_lgr_index_all - - REAL(R8), DIMENSION(ncorner,ntarget), INTENT(IN) :: target_corner_lon, target_corner_lat - - INTEGER, DIMENSION(ncorner+1) :: ipanel_array, ipanel_tmp - REAL(R8), DIMENSION(ncorner) :: lat, lon - REAL(R8), DIMENSION(0:ncube+2):: xgno, ygno - REAL(R8), DIMENSION(0:ncorner+1) :: xcell, ycell - - REAL(R8), DIMENSION(ngauss) :: gauss_weights, abscissae - - REAL(R8) :: da, tmp, alpha, beta - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: pih = 0.50*pi - INTEGER :: i, j,ncorner_this_cell,k,ip,ipanel,ii,jx,jy,jcollect - integer :: alloc_error - - REAL (r8), PARAMETER :: rad2deg = 180.0/pi - - real(r8), allocatable, dimension(:,:) :: weights - integer , allocatable, dimension(:,:) :: weights_eul_index - - - LOGICAL:: ldbg = .FAlSE. - - INTEGER :: jall_anticipated - - jall_anticipated = jall - - ipanel_array = -99 - ! - da = pih/DBLE(ncube) - xgno(0) = -bignum - DO i=1,ncube+1 - xgno(i) = TAN(-piq+(i-1)*da) - END DO - xgno(ncube+2) = bignum - ygno = xgno - - CALL glwp(ngauss,gauss_weights,abscissae) - - - allocate (weights(jmax_segments,nreconstruction),stat=alloc_error ) - allocate (weights_eul_index(jmax_segments,2),stat=alloc_error ) - - tmp = 0.0 - jall = 1 - DO i=1,ntarget - WRITE(*,*) "cell",i," ",100.0*DBLE(i)/DBLE(ntarget),"% done" - ! - !--------------------------------------------------- - ! - ! determine how many vertices the cell has - ! - !--------------------------------------------------- - ! - CALL remove_duplicates_latlon(ncorner,target_corner_lon(:,i),target_corner_lat(:,i),& - ncorner_this_cell,lon,lat,1.0E-10,ldbg) - - IF (ldbg) THEN - WRITE(*,*) "number of vertices ",ncorner_this_cell - WRITE(*,*) "vertices locations lon,",lon(1:ncorner_this_cell)*rad2deg - WRITE(*,*) "vertices locations lat,",lat(1:ncorner_this_cell)*rad2deg - DO j=1,ncorner_this_cell - WRITE(*,*) lon(j)*rad2deg, lat(j)*rad2deg - END DO - WRITE(*,*) " " - END IF - ! - !--------------------------------------------------- - ! - ! determine how many and which panels the cell spans - ! - !--------------------------------------------------- - ! - DO j=1,ncorner_this_cell - CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ipanel_tmp(j), .TRUE.) - IF (ldbg) WRITE(*,*) "ipanel for corner ",j," is ",ipanel_tmp(j) - END DO - ipanel_tmp(ncorner_this_cell+1) = ipanel_tmp(1) - ! make sure to include possible overlap areas not on the face the vertices are located - IF (MINVAL(lat(1:ncorner_this_cell))<-pi/6.0) THEN - ! include South-pole panel in search - ipanel_tmp(ncorner_this_cell+1) = 5 - IF (ldbg) WRITE(*,*) "add panel 5 to search" - END IF - IF (MAXVAL(lat(1:ncorner_this_cell))>pi/6.0) THEN - ! include North-pole panel in search - ipanel_tmp(ncorner_this_cell+1) = 6 - IF (ldbg) WRITE(*,*) "add panel 6 to search" - END IF - ! - ! remove duplicates in ipanel_tmp - ! - CALL remove_duplicates_integer(ncorner_this_cell+1,ipanel_tmp(1:ncorner_this_cell+1),& - k,ipanel_array(1:ncorner_this_cell+1)) - ! - !--------------------------------------------------- - ! - ! loop over panels with possible overlap areas - ! - !--------------------------------------------------- - ! - DO ip = 1,k - ipanel = ipanel_array(ip) - DO j=1,ncorner_this_cell - ii = ipanel - CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ii,.FALSE.) - IF (j==1) THEN - jx = CEILING((alpha + piq) / da) - jy = CEILING((beta + piq) / da) - END IF - xcell(ncorner_this_cell+1-j) = TAN(alpha) - ycell(ncorner_this_cell+1-j) = TAN(beta) - END DO - xcell(0) = xcell(ncorner_this_cell) - ycell(0) = ycell(ncorner_this_cell) - xcell(ncorner_this_cell+1) = xcell(1) - ycell(ncorner_this_cell+1) = ycell(1) - - jx = MAX(MIN(jx,ncube+1),0) - jy = MAX(MIN(jy,ncube+1),0) - - CALL compute_weights_cell(xcell(0:ncorner_this_cell+1),ycell(0:ncorner_this_cell+1),& - jx,jy,nreconstruction,xgno,ygno,& - 1, ncube+1, 1,ncube+1, tmp,& - ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,& - ncube,0,ncorner_this_cell,ldbg) - - weights_all(jall:jall+jcollect-1,1:nreconstruction) = weights(1:jcollect,1:nreconstruction) - - weights_eul_index_all(jall:jall+jcollect-1,1:2) = weights_eul_index(1:jcollect,:) - weights_eul_index_all(jall:jall+jcollect-1, 3) = ipanel - weights_lgr_index_all(jall:jall+jcollect-1 ) = i - - jall = jall+jcollect - IF (jall>jall_anticipated) THEN - WRITE(*,*) "more weights than anticipated" - WRITE(*,*) "increase jall" - STOP - END IF - IF (ldbg) WRITE(*,*) "jcollect",jcollect - END DO - END DO - jall = jall-1 - WRITE(*,*) "sum of all weights divided by surface area of sphere =",tmp/(4.0*pi) - WRITE(*,*) "actual number of weights",jall - WRITE(*,*) "anticipated number of weights",jall_anticipated - IF (jall>jall_anticipated) THEN - WRITE(*,*) "anticipated number of weights < actual number of weights" - WRITE(*,*) "increase jall!" - STOP - END IF - WRITE(*,*) MINVAL(weights_all(1:jall,1)),MAXVAL(weights_all(1:jall,1)) - IF (ABS(tmp/(4.0*pi))-1.0>0.001) THEN - WRITE(*,*) "sum of all weights does not match the surface area of the sphere" - WRITE(*,*) "sum of all weights is : ",tmp - WRITE(*,*) "surface area of sphere: ",4.0*pi - STOP - END IF -END SUBROUTINE overlap_weights - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereABPFromRLL -! -! Description: -! Determine the (alpha,beta,panel) coordinate of a point on the sphere from -! a given regular lat lon coordinate. -! -! Parameters: -! lon - Coordinate longitude -! lat - Coordinate latitude -! alpha (OUT) - Alpha coordinate -! beta (OUT) - Beta coordinate -! ipanel (OUT) - Face panel -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel, ldetermine_panel) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (R8), INTENT(IN) :: lon, lat - REAL (R8), INTENT(OUT) :: alpha, beta - INTEGER :: ipanel - LOGICAL, INTENT(IN) :: ldetermine_panel - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: rotate_cube = 0.0 - - ! Local variables - REAL (R8) :: xx, yy, zz, pm - REAL (R8) :: sx, sy, sz - INTEGER :: ix, iy, iz - - ! Translate to (x,y,z) space - xx = COS(lon-rotate_cube) * COS(lat) - yy = SIN(lon-rotate_cube) * COS(lat) - zz = SIN(lat) - - pm = MAX(ABS(xx), ABS(yy), ABS(zz)) - - ! Check maximality of the x coordinate - IF (pm == ABS(xx)) THEN - IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF - ELSE - ix = 0 - ENDIF - - ! Check maximality of the y coordinate - IF (pm == ABS(yy)) THEN - IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF - ELSE - iy = 0 - ENDIF - - ! Check maximality of the z coordinate - IF (pm == ABS(zz)) THEN - IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF - ELSE - iz = 0 - ENDIF - - ! Panel assignments - IF (ldetermine_panel) THEN - IF (iz == 1) THEN - ipanel = 6; sx = yy; sy = -xx; sz = zz - - ELSEIF (iz == -1) THEN - ipanel = 5; sx = yy; sy = xx; sz = -zz - - ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN - ipanel = 1; sx = yy; sy = zz; sz = xx - - ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN - ipanel = 3; sx = -yy; sy = zz; sz = -xx - - ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN - ipanel = 2; sx = -xx; sy = zz; sz = yy - - ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN - ipanel = 4; sx = xx; sy = zz; sz = -yy - - ELSE - WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed' - WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')' - WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')' - STOP - ENDIF - ELSE - IF (ipanel == 6) THEN - sx = yy; sy = -xx; sz = zz - ELSEIF (ipanel == 5) THEN - sx = yy; sy = xx; sz = -zz - ELSEIF (ipanel == 1) THEN - sx = yy; sy = zz; sz = xx - ELSEIF (ipanel == 3) THEN - sx = -yy; sy = zz; sz = -xx - ELSEIF (ipanel == 2) THEN - sx = -xx; sy = zz; sz = yy - ELSEIF (ipanel == 4) THEN - sx = xx; sy = zz; sz = -yy - ELSE - WRITE(*,*) "ipanel out of range",ipanel - STOP - END IF - END IF - - ! Use panel information to calculate (alpha, beta) coords - alpha = ATAN(sx / sz) - beta = ATAN(sy / sz) - -END SUBROUTINE CubedSphereABPFromRLL - -!------------------------------------------------------------------------------ -! SUBROUTINE EquiangularAllAreas -! -! Description: -! Compute the area of all cubed sphere grid cells, storing the results in -! a two dimensional array. -! -! Parameters: -! icube - Resolution of the cubed sphere -! dA (OUT) - Output array containing the area of all cubed sphere grid cells -!------------------------------------------------------------------------------ -SUBROUTINE EquiangularAllAreas(icube, dA) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: icube - REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA - - ! Local variables - INTEGER :: k, k1, k2 - REAL (r8) :: a1, a2, a3, a4 - REAL (r8), DIMENSION(icube+1,icube+1) :: ang - REAL (r8), DIMENSION(icube+1) :: gp - - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - - !#ifdef DBG - REAL (r8) :: dbg1 !DBG - !#endif - - ! Recall that we are using equi-angular spherical gridding - ! Compute the angle between equiangular cubed sphere projection grid lines. - DO k = 1, icube+1 - gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1) - ENDDO - - DO k2=1,icube+1 - DO k1=1,icube+1 - ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2))) - ENDDO - ENDDO - - DO k2=1,icube - DO k1=1,icube - a1 = ang(k1 , k2 ) - a2 = pi - ang(k1+1, k2 ) - a3 = pi - ang(k1 , k2+1) - a4 = ang(k1+1, k2+1) - ! area = r*r*(-2*pi+sum(interior angles)) - DA(k1,k2) = -2.0*pi+a1+a2+a3+a4 - ENDDO - ENDDO - - !#ifdef DBG - ! Only for debugging - test consistency - dbg1 = 0.0 !DBG - DO k2=1,icube - DO k1=1,icube - dbg1 = dbg1 + DA(k1,k2) !DBG - ENDDO - ENDDO - write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG - !#endif -END SUBROUTINE EquiangularAllAreas - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereRLLFromABP -! -! Description: -! Determine the lat lon coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! lon (OUT) - Calculated longitude -! lat (OUT) - Calculated latitude -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: lon, lat - ! Local variables - REAL (r8) :: xx, yy, zz, rotate_cube - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - rotate_cube = 0.0 - ! Convert to cartesian coordinates - CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - ! Convert back to lat lon - lat = ASIN(zz) - if (xx==0.0.and.yy==0.0) THEN - lon = 0.0 - else - lon = ATAN2(yy, xx) +rotate_cube - IF (lon<0.0) lon=lon+2.0*pi - IF (lon>2.0*pi) lon=lon-2.0*pi - end if -END SUBROUTINE CubedSphereRLLFromABP - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereXYZFromABP -! -! Description: -! Determine the Cartesian coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! xx (OUT) - Calculated x coordinate -! yy (OUT) - Calculated y coordinate -! zz (OUT) - Calculated z coordinate -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: xx, yy, zz - ! Local variables - REAL (r8) :: a1, b1, pm - REAL (r8) :: sx, sy, sz - - ! Convert to Cartesian coordinates - a1 = TAN(alpha) - b1 = TAN(beta) - - sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5) - sx = sz * a1 - sy = sz * b1 - ! Panel assignments - IF (ipanel == 6) THEN - yy = sx; xx = -sy; zz = sz - ELSEIF (ipanel == 5) THEN - yy = sx; xx = sy; zz = -sz - ELSEIF (ipanel == 1) THEN - yy = sx; zz = sy; xx = sz - ELSEIF (ipanel == 3) THEN - yy = -sx; zz = sy; xx = -sz - ELSEIF (ipanel == 2) THEN - xx = -sx; zz = sy; yy = sz - ELSEIF (ipanel == 4) THEN - xx = sx; zz = sy; yy = -sz - ELSE - WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP' - WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')' - STOP - ENDIF -END SUBROUTINE CubedSphereXYZFromABP - - -SUBROUTINE remove_duplicates_integer(n_in,f_in,n_out,f_out) - use shr_kind_mod, only: r8 => shr_kind_r8 - integer, intent(in) :: n_in - integer,dimension(n_in), intent(in) :: f_in - integer, intent(out) :: n_out - integer,dimension(n_in), intent(out) :: f_out - ! - ! local work space - ! - integer :: k,i,j - ! - ! remove duplicates in ipanel_tmp - ! - k = 1 - f_out(1) = f_in(1) - outer: do i=2,n_in - do j=1,k - ! if (f_out(j) == f_in(i)) then - if (ABS(f_out(j)-f_in(i))<1.0E-10) then - ! Found a match so start looking again - cycle outer - end if - end do - ! No match found so add it to the output - k = k + 1 - f_out(k) = f_in(i) - end do outer - n_out = k -END SUBROUTINE remove_duplicates_integer - -SUBROUTINE remove_duplicates_latlon(n_in,lon_in,lat_in,n_out,lon_out,lat_out,tiny,ldbg) - use shr_kind_mod, only: r8 => shr_kind_r8 - integer, intent(in) :: n_in - real(r8),dimension(n_in), intent(inout) :: lon_in,lat_in - real, intent(in) :: tiny - integer, intent(out) :: n_out - real(r8),dimension(n_in), intent(out) :: lon_out,lat_out - logical :: ldbg - ! - ! local work space - ! - integer :: k,i,j - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: pih = 0.50*pi - ! - ! for pole points: make sure the longitudes are identical so that algorithm below works properly - ! - do i=2,n_in - if (abs(lat_in(i)-pih) 0) .AND. (j < ncube_reconstruct)) THEN - beta = gp(j) - beta_next = gp(j+1) - ELSEIF (j == -1) THEN - beta = -piq - (gp(3) + piq) - beta_next = -piq - (gp(2) + piq) - ELSEIF (j == 0) THEN - beta = -piq - (gp(2) + piq) - beta_next = -piq - ELSEIF (j == ncube_reconstruct) THEN - beta = piq - beta_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (j == ncube_reconstruct+1) THEN - beta = piq + (piq - gp(ncube_reconstruct-1)) - beta_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - - DO i = -1, ncube_reconstruct+1 - IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN - alpha = gp(i) - alpha_next = gp(i+1) - ELSEIF (i == -1) THEN - alpha = -piq - (gp(3) + piq) - alpha_next = -piq - (gp(2) + piq) - ELSEIF (i == 0) THEN - alpha = -piq - (gp(2) + piq) - alpha_next = -piq - ELSEIF (i == ncube_reconstruct) THEN - alpha = piq - alpha_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (i == ncube_reconstruct+1) THEN - alpha = piq + (piq - gp(ncube_reconstruct-1)) - alpha_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - abp_centroid(1,i,j) = & - I_10_ab(alpha_next,beta_next)-I_10_ab(alpha ,beta_next)+& - I_10_ab(alpha ,beta )-I_10_ab(alpha_next,beta ) -! - ASINH(COS(alpha_next) * TAN(beta_next)) & -! + ASINH(COS(alpha_next) * TAN(beta)) & -! + ASINH(COS(alpha) * TAN(beta_next)) & -! - ASINH(COS(alpha) * TAN(beta)) - - abp_centroid(2,i,j) = & - I_01_ab(alpha_next,beta_next)-I_01_ab(alpha ,beta_next)+& - I_01_ab(alpha ,beta )-I_01_ab(alpha_next,beta ) -! - ASINH(TAN(alpha_next) * COS(beta_next)) & -! + ASINH(TAN(alpha_next) * COS(beta)) & -! + ASINH(TAN(alpha) * COS(beta_next)) & -! - ASINH(TAN(alpha) * COS(beta)) - - !ADD PHL START - IF (order>2) THEN - ! TAN(alpha)^2 component - abp_centroid(3,i,j) =& - I_20_ab(alpha_next,beta_next)-I_20_ab(alpha ,beta_next)+& - I_20_ab(alpha ,beta )-I_20_ab(alpha_next,beta ) - - ! TAN(beta)^2 component - abp_centroid(4,i,j) = & - I_02_ab(alpha_next,beta_next)-I_02_ab(alpha ,beta_next)+& - I_02_ab(alpha ,beta )-I_02_ab(alpha_next,beta ) - - ! TAN(alpha) TAN(beta) component - abp_centroid(5,i,j) = & - I_11_ab(alpha_next,beta_next)-I_11_ab(alpha ,beta_next)+& - I_11_ab(alpha ,beta )-I_11_ab(alpha_next,beta ) - ENDIF - !ADD PHL END - ENDDO - ENDDO - -! -! PHL outcommented below -! - ! High order calculations -! IF (order > 2) THEN -! DO k = 1, nlon -! DO i = 1, int_nx(nlat,k)-1 -! IF ((int_itype(i,k) > 4) .AND. (int_np(1,i,k) == 1)) THEN -! abp_centroid(3, int_a(i,k), int_b(i,k)) = & -! abp_centroid(3, int_a(i,k), int_b(i,k)) + int_wt_2a(i,k) -! abp_centroid(4, int_a(i,k), int_b(i,k)) = & -! abp_centroid(4, int_a(i,k), int_b(i,k)) + int_wt_2b(i,k) -! abp_centroid(5, int_a(i,k), int_b(i,k)) = & -! abp_centroid(5, int_a(i,k), int_b(i,k)) + int_wt_2c(i,k) -! ENDIF -! ENDDO -! ENDDO -! ENDIF - - ! Normalize with element areas - DO j = -1, ncube_reconstruct+1 - IF ((j > 0) .AND. (j < ncube_reconstruct)) THEN - beta = gp(j) - beta_next = gp(j+1) - ELSEIF (j == -1) THEN - beta = -piq - (gp(3) + piq) - beta_next = -piq - (gp(2) + piq) - ELSEIF (j == 0) THEN - beta = -piq - (gp(2) + piq) - beta_next = -piq - ELSEIF (j == ncube_reconstruct) THEN - beta = piq - beta_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (j == ncube_reconstruct+1) THEN - beta = piq + (piq - gp(ncube_reconstruct-1)) - beta_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - DO i = -1, ncube_reconstruct+1 - IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN - alpha = gp(i) - alpha_next = gp(i+1) - ELSEIF (i == -1) THEN - alpha = -piq - (gp(3) + piq) - alpha_next = -piq - (gp(2) + piq) - ELSEIF (i == 0) THEN - alpha = -piq - (gp(2) + piq) - alpha_next = -piq - ELSEIF (i == ncube_reconstruct) THEN - alpha = piq - alpha_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (i == ncube_reconstruct+1) THEN - alpha = piq + (piq - gp(ncube_reconstruct-1)) - alpha_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - - IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - area = DAcube(i,j) - ELSE - area = EquiangularElementArea(alpha, alpha_next - alpha, & - beta, beta_next - beta) - ENDIF - - abp_centroid(1,i,j) = abp_centroid(1,i,j) / area - abp_centroid(2,i,j) = abp_centroid(2,i,j) / area - - IF (order > 2) THEN - IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - abp_centroid(3,i,j) = abp_centroid(3,i,j) / area - abp_centroid(4,i,j) = abp_centroid(4,i,j) / area - abp_centroid(5,i,j) = abp_centroid(5,i,j) / area - ENDIF - ENDIF - ENDDO - ENDDO - - WRITE(*,*) '...Done computing ABP element centroids' - - END SUBROUTINE ComputeABPElementCentroids - -!------------------------------------------------------------------------------ -! FUNCTION EvaluateABPReconstruction -! -! Description: -! Evaluate the sub-grid scale reconstruction at the given point. -! -! Parameters: -! fcubehalo - Array of element values -! recons - Array of reconstruction coefficients -! a - Index of element in alpha direction (1 <= a <= ncube_reconstruct-1) -! b - Index of element in beta direction (1 <= b <= ncube_reconstruct-1) -! p - Panel index of element -! alpha - Alpha coordinate of evaluation point -! beta - Beta coordinate of evaluation point -! order - Order of the reconstruction -! value (OUT) - Result of function evaluation at given point -!------------------------------------------------------------------------------ - SUBROUTINE EvaluateABPReconstruction( & - fcubehalo, recons, a, b, p, alpha, beta, order, value) - IMPLICIT NONE - - ! Dummy variables - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(IN) :: recons - INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p - REAL (KIND=dbl_kind), INTENT(IN) :: alpha, beta - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), INTENT(OUT) :: value - - ! Evaluate constant order terms - value = fcubehalo(a,b,p) - - ! Evaluate linear order terms - IF (order > 1) THEN - value = value + recons(1,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) - value = value + recons(2,a,b,p) * (TAN(beta) - abp_centroid(2,a,b)) - ENDIF - - ! Evaluate second order terms - IF (order > 2) THEN - value = value + recons(3,a,b,p) * & - (abp_centroid(1,a,b)**2 - abp_centroid(3,a,b)) - value = value + recons(4,a,b,p) * & - (abp_centroid(2,a,b)**2 - abp_centroid(4,a,b)) - value = value + recons(5,a,b,p) * & - (abp_centroid(1,a,b) * abp_centroid(2,a,b) - & - abp_centroid(5,a,b)) - - value = value + recons(3,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b))**2 - value = value + recons(4,a,b,p) * (TAN(beta) - abp_centroid(2,a,b))**2 - value = value + recons(5,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) & - * (TAN(beta) - abp_centroid(2,a,b)) - ENDIF - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ABPHaloMinMax -! -! Description: -! Calculate the minimum and maximum values of the cell-averaged function -! around the given element. -! -! Parameters: -! fcubehalo - Cell-averages for the cubed sphere -! a - Local element alpha index -! b - Local element beta index -! p - Local element panel index -! min_val (OUT) - Minimum value in the halo -! max_val (OUT) - Maximum value in the halo -! nomiddle - whether to not include the middle cell (index a,b) in the search. -! -! NOTE: Since this routine is not vectorized, it will likely be called MANY times. -! To speed things up, make sure to pass the first argument as the ENTIRE original -! array, not as a subset of it, since repeatedly cutting up that array and creating -! an array temporary (on some compilers) is VERY slow. -! ex: -! CALL APBHaloMinMax(zarg, a, ...) !YES -! CALL ABPHaloMinMax(zarg(-1:ncube_reconstruct+1,-1:ncube_reconstruct+1,:)) !NO -- slow -!------------------------------------------------------------------------------ - SUBROUTINE ABPHaloMinMax(fcubehalo, a, b, p, min_val, max_val, nomiddle) - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p - REAL (KIND=dbl_kind), INTENT(OUT) :: min_val, max_val - LOGICAL, INTENT(IN) :: nomiddle - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, il, jl, inew, jnew - REAL (KIND=dbl_kind) :: value - - min_val = fcubehalo(a,b,p) - max_val = fcubehalo(a,b,p) - value = fcubehalo(a,b,p) - - DO il = a-1,a+1 - DO jl = b-1,b+1 - - i = il - j = jl - - inew = i - jnew = j - - IF (nomiddle .AND. i==a .AND. j==b) CYCLE - - !Interior - IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - value = fcubehalo(i,j,p) - - ELSE - - - !The next 4.0 regions are cases in which a,b themselves lie in the panel's halo, and the cell's "halo" (in this usage the 8.0 cells surrounding it) might wrap around into another part of the halo. This happens for (a,b) = {(1,:0),(ncube_reconstruct-1,:0),(1,ncube_reconstruct:),(ncube_reconstruct-1,ncube_reconstruct:)} and for the transposes thereof ({(:0,1), etc.}). In these cases (i,j) could lie in the "Corners" where nothing should lie. We correct this by moving i,j to its appropriate position on the "facing" halo, and then the remainder of the routine then moves it onto the correct face. - -101 FORMAT("ERROR cannot find (i,j) = (", I4, ", ", I4, ") for (a,b,p) = ", I4, ",", I4, ",", I4, ")") -102 FORMAT("i,j,p = ", 3I4, " moved to " 2I4, " (CASE ", I1, ")") - !NOTE: we need the general case to be able to properly handle (0,0), (ncube_reconstruct,0), etc. Note that we don't need to bother with (0,0), etc. when a, b lie in the interior, since both sides of the (0,0) cell are already accounted for by this routine. - !LOWER LEFT - IF (i < 1 .AND. j < 1) THEN - IF (a < 1) THEN !(a,b) centered on left halo, cross to lower halo - inew = 1-j - jnew = i - ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to left halo - jnew = 1-i - inew = j - END IF -! WRITE(*,102) i, j, p, inew, jnew, 1 - !LOWER RIGHT - ELSE IF (i > ncube_reconstruct-1 .AND. j < 1) THEN - IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to lower halo - inew = ncube_reconstruct-1+j - jnew = ncube_reconstruct-i - ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to right halo - jnew = 1+(i-ncube_reconstruct) - inew = ncube_reconstruct-j - END IF -! WRITE(*,102) i, j, p, inew, jnew, 2 - !UPPER LEFT - ELSE IF (i < 1 .AND. j > ncube_reconstruct-1) THEN - IF (a < 1) THEN! (a,b) centered on left halo, cross to upper halo - inew = 1-(j-ncube_reconstruct) - jnew = ncube_reconstruct-i - ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to left halo - inew = ncube_reconstruct-j - jnew = ncube_reconstruct-1-i - END IF -! WRITE(*,102) i, j, p, inew, jnew, 3 - !UPPER RIGHT - ELSE IF (i > ncube_reconstruct-1 .AND. j > ncube_reconstruct-1) THEN - IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to upper halo - inew = ncube_reconstruct-1-(ncube_reconstruct-j) - jnew = i - ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to right halo - inew = j - jnew = ncube_reconstruct-1-(ncube_reconstruct-i) - END IF -! WRITE(*,102) i, j, p, inew, jnew, 4 - END IF - - i = inew - j = jnew - - - !Lower halo ("halo" meaning the panel's halo, not the nine-cell halo - IF ((i < 1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,4) - ELSEIF (p == 2) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,1) - ELSEIF (p == 3) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,2) - ELSEIF (p == 4) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,3) - ELSEIF (p == 5) THEN - value = fcubehalo(j,1-i,4) - ELSEIF (p == 6) THEN - value = fcubehalo(ncube_reconstruct-j,ncube_reconstruct-1+i,4) - ENDIF - - !Upper halo - ELSEIF ((i > ncube_reconstruct-1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,2) - ELSEIF (p == 2) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,3) - ELSEIF (p == 3) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,4) - ELSEIF (p == 4) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,1) - ELSEIF (p == 5) THEN - value = fcubehalo(ncube_reconstruct-j,i-ncube_reconstruct+1,2) - ELSEIF (p == 6) THEN - value = fcubehalo(j,2*ncube_reconstruct-i-1,2) - ENDIF - - !Left halo - ELSEIF ((j < 1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(i,ncube_reconstruct-1+j,5) - ELSEIF (p == 2) THEN - value = fcubehalo(ncube_reconstruct-1+j,ncube_reconstruct-i,5) - ELSEIF (p == 3) THEN - value = fcubehalo(ncube_reconstruct-i,1-j,5) - ELSEIF (p == 4) THEN - value = fcubehalo(1-j,i,5) - ELSEIF (p == 5) THEN - value = fcubehalo(ncube_reconstruct-i,1-j,3) - ELSEIF (p == 6) THEN - value = fcubehalo(i,ncube_reconstruct-1+j,1) - ENDIF - - !Right halo - ELSEIF ((j > ncube_reconstruct-1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(i,j-ncube_reconstruct+1,6) - ELSEIF (p == 2) THEN - value = fcubehalo(2*ncube_reconstruct-j-1,i,6) - ELSEIF (p == 3) THEN - value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,6) - ELSEIF (p == 4) THEN - value = fcubehalo(j-ncube_reconstruct+1,ncube_reconstruct-i,6) - ELSEIF (p == 5) THEN - value = fcubehalo(i,j-ncube_reconstruct+1,1) - ELSEIF (p == 6) THEN - value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,3) - ENDIF - - ENDIF - - END IF - min_val = MIN(min_val, value) - max_val = MAX(max_val, value) - ENDDO - ENDDO - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE MonotonizeABPGradient -! -! Description: -! Apply a monotonic filter to the calculated ABP gradient. -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! selective - whether to apply a simple form of selective limiting, - !which assumes that if a point is larger/smaller than ALL of its - !surrounding points, that the extremum is physical, and that - !filtering should not be applied to it. -! -! Remarks: -! This monotonizing scheme is based on the monotone scheme for unstructured -! grids of Barth and Jespersen (1989). -!------------------------------------------------------------------------------ - SUBROUTINE MonotonizeABPGradient(fcubehalo, order, recons, selective) - -! USE selective_limiting - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - LOGICAL, INTENT(IN) :: selective - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n, skip - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi - REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: & - gamma - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - -! -! xxxxx -! -! IF (selective) THEN -! CALL smoothness2D(fcubehalo, gamma, 2) -! WRITE(*,*) 'gamma range: max ', MAXVAL(gamma), " min ", MINVAL(gamma) -! DO i=1,ncube_reconstruct-1 -! WRITE(*,*) gamma(i, i, 3) -! ENDDO -! skip = 0 -! END IF - - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - - - IF (selective) THEN - - CALL ABPHaloMinMax(gamma, i, j, k, gamma_min, gamma_max, .FALSE.) - - IF (gamma_max/(gamma_min + tiny) < lammax) THEN - skip = skip + 1 - CYCLE - END IF - - END IF - - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) - - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), local_min, local_max, min_phi) - ENDDO - ENDDO - - ! For the third order method, the minima and maxima may occur along - ! the line segments given by du/dx = 0 and du/dy = 0. Also check - ! for the presence of a maxima / minima of the quadratic within - ! the domain. - IF (order == 3) THEN - disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) - - ! Check if the quadratic is minimized within the element - IF (ABS(disc) > tiny) THEN - mx = - recons(5,i,j,k) * recons(2,i,j,k) & - + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) - my = - recons(5,i,j,k) * recons(1,i,j,k) & - + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) - - mx = mx / disc + abp_centroid(1,i,j) - my = my / disc + abp_centroid(2,i,j) - - IF ((mx - TAN(gp(i)) > -tiny) .AND. & - (mx - TAN(gp(i+1)) < tiny) .AND. & - (my - TAN(gp(j)) > -tiny) .AND. & - (my - TAN(gp(j+1)) < tiny) & - ) THEN - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDIF - ENDIF - - ! Check all potential minimizer points along element boundaries - IF (ABS(recons(5,i,j,k)) > tiny) THEN - - ! Left/right edge, intercept with du/dx = 0 - DO m = i, i+1 - my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / recons(5,i,j,k) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - - ! Top/bottom edge, intercept with du/dy = 0 - DO n = j, j+1 - mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Top/bottom edge, intercept with du/dx = 0 - IF (ABS(recons(3,i,j,k)) > tiny) THEN - DO n = j, j+1 - mx = - recons(1,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Left/right edge, intercept with du/dy = 0 - IF (ABS(recons(4,i,j,k)) > tiny) THEN - DO m = i, i+1 - my = - recons(2,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - ENDIF - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - ! Apply monotone limiter to all reconstruction coefficients - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - IF (order > 2) THEN - recons(3,i,j,k) = min_phi * recons(3,i,j,k) - recons(4,i,j,k) = min_phi * recons(4,i,j,k) - recons(5,i,j,k) = min_phi * recons(5,i,j,k) - ENDIF - ENDDO - ENDDO - ENDDO - - IF (selective) WRITE(*,*) 'skipped ', skip, ' points out of ', 6*(ncube_reconstruct-1)**2 - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE PosDefABPGradient -! -! Description: -! Scale the reconstructions so they are positive definite -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! -! Remarks: -! This monotonizing scheme is based on the monotone scheme for unstructured -! grids of Barth and Jespersen (1989), but simpler. This simply finds the -! minimum and then scales the reconstruction so that it is 0. -!------------------------------------------------------------------------------ - SUBROUTINE PosDefABPGradient(fcubehalo, order, recons) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi - REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: & - gamma - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - - !If the average value in the cell is 0.0, then we should skip - !all of the scaling and just set the reconstruction to 0.0 -! IF (ABS(fcubehalo(i,j,k)) < tiny) THEN -! recons(:,i,j,k) = 0.0 -! CYCLE -! END IF - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) - - - !This allowance for miniscule negative values appearing around the cell being - !filtered/limited. Before this, negative values would be caught in adjust_limiter - !and would stop the model. Doing this only causes minor negative values; no blowing - !up is observed. The rationale is the same as for the monotone filter, which does - !allow miniscule negative values due to roundoff error --- of the order E-10 --- - !in flux-form methods (and E-17 in the s-L method, indicating that roundoff error - !is more severe in the flux-form method, as we expect since we are often subtracting - !2.0 values which are very close together. - local_min = MIN(0.0,local_min) - local_max = bignum !prevents scaling upward; for positive - !definite limiting we don't care about the upper bound - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), local_min, local_max, min_phi) - ENDDO - ENDDO - - ! For the third order method, the minima and maxima may occur along - ! the line segments given by du/dx = 0 and du/dy = 0. Also check - ! for the presence of a maxima / minima of the quadratic within - ! the domain. - IF (order == 3) THEN - disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) - - ! Check if the quadratic is minimized within the element - IF (ABS(disc) > tiny) THEN - mx = - recons(5,i,j,k) * recons(2,i,j,k) & - + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) - my = - recons(5,i,j,k) * recons(1,i,j,k) & - + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) - - mx = mx / disc + abp_centroid(1,i,j) - my = my / disc + abp_centroid(2,i,j) - - IF ((mx - TAN(gp(i)) > -tiny) .AND. & - (mx - TAN(gp(i+1)) < tiny) .AND. & - (my - TAN(gp(j)) > -tiny) .AND. & - (my - TAN(gp(j+1)) < tiny) & - ) THEN - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDIF - ENDIF - - ! Check all potential minimizer points along element boundaries - IF (ABS(recons(5,i,j,k)) > tiny) THEN - - ! Left/right edge, intercept with du/dx = 0 - DO m = i, i+1 - my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / recons(5,i,j,k) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - - ! Top/bottom edge, intercept with du/dy = 0 - DO n = j, j+1 - mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Top/bottom edge, intercept with du/dx = 0 - IF (ABS(recons(3,i,j,k)) > tiny) THEN - DO n = j, j+1 - mx = - recons(1,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Left/right edge, intercept with du/dy = 0 - IF (ABS(recons(4,i,j,k)) > tiny) THEN - DO m = i, i+1 - my = - recons(2,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - ENDIF - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - ! Apply monotone limiter to all reconstruction coefficients - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - IF (order > 2) THEN - recons(3,i,j,k) = min_phi * recons(3,i,j,k) - recons(4,i,j,k) = min_phi * recons(4,i,j,k) - recons(5,i,j,k) = min_phi * recons(5,i,j,k) - ENDIF - - ENDDO - ENDDO - ENDDO - - - END SUBROUTINE PosDefABPGradient - -!------------------------------------------------------------------------------ -! SUBROUTINE MonotonizeABPGradient_New -! -! Description: -! Apply a monotonic filter to the calculated ABP gradient. -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! -! Remarks: -! This monotonizing scheme is similar to the one in MonotonizeABPGradient, -! except the second order derivatives are limited after the first order -! derivatives. -!------------------------------------------------------------------------------ - SUBROUTINE MonotonizeABPGradient_New(fcubehalo, order, recons) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, linval - REAL (KIND=dbl_kind) :: disc, mx, my - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max, .FALSE.) - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point, only taking into - ! account the linear component of the reconstruction. - value = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), local_min, local_max, min_phi) - ENDDO - ENDDO - - ! Apply monotone limiter to all reconstruction coefficients - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - ! For the third order method, the minima and maxima may occur along - ! the line segments given by du/dx = 0 and du/dy = 0. Also check - ! for the presence of a maxima / minima of the quadratic within - ! the domain. - IF (order == 3) THEN - ! Reset the limiter - min_phi = one - - ! Calculate discriminant, which we use to determine the absolute - ! minima/maxima of the paraboloid - disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) - - ! Check if the quadratic is minimized within the element - IF (ABS(disc) > tiny) THEN - mx = - recons(5,i,j,k) * recons(2,i,j,k) & - + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) - my = - recons(5,i,j,k) * recons(1,i,j,k) & - + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) - - mx = mx / disc + abp_centroid(1,i,j) - my = my / disc + abp_centroid(2,i,j) - - IF ((mx - TAN(gp(i)) > -tiny) .AND. & - (mx - TAN(gp(i+1)) < tiny) .AND. & - (my - TAN(gp(j)) > -tiny) .AND. & - (my - TAN(gp(j+1)) < tiny) & - ) THEN - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDIF - ENDIF - - ! Check all potential minimizer points along element boundaries - IF (ABS(recons(5,i,j,k)) > tiny) THEN - - ! Left/right edge, intercept with du/dx = 0 - DO m = i, i+1 - my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / recons(5,i,j,k) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - - ! Top/bottom edge, intercept with du/dy = 0 - DO n = j, j+1 - mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Top/bottom edge, intercept with du/dx = 0 - IF (ABS(recons(3,i,j,k)) > tiny) THEN - DO n = j, j+1 - mx = - recons(1,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Left/right edge, intercept with du/dy = 0 - IF (ABS(recons(4,i,j,k)) > tiny) THEN - DO m = i, i+1 - my = - recons(2,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDIF - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDDO - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - WRITE (*,*) '2: ', min_phi - - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - recons(3,i,j,k) = min_phi * recons(3,i,j,k) - recons(4,i,j,k) = min_phi * recons(4,i,j,k) - recons(5,i,j,k) = min_phi * recons(5,i,j,k) - ENDIF - ENDDO - ENDDO - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_NEL -! -! Description: -! Construct a non-equidistant linear reconstruction of the gradient -! within each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_NEL(fcubehalo, recons, order) - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: alpha1, alpha2, beta1, beta2 - REAL (KIND=dbl_kind) :: dx_left, dx_right, top_value, bot_value - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) - dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) - - recons(1,i,j,p) = & - (+ fcubehalo(i-1,j,p) * dx_right**2 & - - fcubehalo(i+1,j,p) * dx_left**2 & - - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(2,i,j,p) = & - (+ fcubehalo(i,j-1,p) * dx_right**2 & - - fcubehalo(i,j+1,p) * dx_left**2 & - - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - IF (order > 2) THEN - dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) - dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) - - recons(3,i,j,p) = & - (+ fcubehalo(i-1,j,p) * dx_right & - - fcubehalo(i+1,j,p) * dx_left & - - fcubehalo(i,j,p) * (dx_right - dx_left)) / & - (dx_right * dx_left * (dx_left - dx_right)) - - dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(4,i,j,p) = & - (+ fcubehalo(i,j-1,p) * dx_right & - - fcubehalo(i,j+1,p) * dx_left & - - fcubehalo(i,j,p) * (dx_right - dx_left)) / & - (dx_right * dx_left * (dx_left - dx_right)) - ENDIF - ENDDO - ENDDO - - IF (order > 2) THEN - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - dx_left = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1) - dx_right = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1) - - top_value = & - (+ fcubehalo(i-1,j+1,p) * dx_right**2 & - - fcubehalo(i+1,j+1,p) * dx_left**2 & - - fcubehalo(i,j+1,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - dx_left = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1) - dx_right = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1) - - bot_value = & - (+ fcubehalo(i-1,j-1,p) * dx_right**2 & - - fcubehalo(i+1,j-1,p) * dx_left**2 & - - fcubehalo(i,j-1,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(5,i,j,p) = & - (+ bot_value * dx_right**2 & - - top_value * dx_left**2 & - - recons(1,i,j,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - ENDDO - ENDDO - ENDIF - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_NEP -! -! Description: -! Construct a non-equidistant parabolic reconstruction of the gradient -! within each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_NEP(fcubehalo, recons, order) - - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: x1, x2, x4, x5, y1, y2, y3, y4, y5 - - REAL (KIND=dbl_kind), DIMENSION(5) :: t, pa, denom - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - ! X-direction reconstruction - x1 = abp_centroid(1,i-2,j) - abp_centroid(1,i,j) - x2 = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) - x4 = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) - x5 = abp_centroid(1,i+2,j) - abp_centroid(1,i,j) - - !IF (i == 1) THEN - ! x1 = piq - !ELSEIF (i == ncube_reconstruct-1) THEN - ! x5 = -piq - !ENDIF - - y1 = fcubehalo(i-2,j,p) - y2 = fcubehalo(i-1,j,p) - y3 = fcubehalo(i,j,p) - y4 = fcubehalo(i+1,j,p) - y5 = fcubehalo(i+2,j,p) - - denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1 - denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2 - denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4 - denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5 - - t(1) = x5 * x4 * x2 - t(2) = x5 * x4 * x1 - t(4) = x5 * x2 * x1 - t(5) = x4 * x2 * x1 - t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5) - - pa(1) = x2 * x4 + x2 * x5 + x4 * x5 - pa(2) = x1 * x4 + x1 * x5 + x4 * x5 - pa(4) = x1 * x2 + x1 * x5 + x2 * x5 - pa(5) = x1 * x2 + x1 * x4 + x2 * x4 - pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5) - - recons(1,i,j,p) = & - + y1 * t(1) / denom(1) & - + y2 * t(2) / denom(2) & - - y3 * t(3) & - + y4 * t(4) / denom(4) & - + y5 * t(5) / denom(5) - - IF (order > 2) THEN - recons(3,i,j,p) = & - - y1 * pa(1) / denom(1) & - - y2 * pa(2) / denom(2) & - + y3 * pa(3) & - - y4 * pa(4) / denom(4) & - - y5 * pa(5) / denom(5) - ENDIF - - ! Y-direction reconstruction - x1 = abp_centroid(2,i,j-2) - abp_centroid(2,i,j) - x2 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - x4 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - x5 = abp_centroid(2,i,j+2) - abp_centroid(2,i,j) - - !IF (j == 1) THEN - ! x1 = piq - !ELSEIF (j == ncube_reconstruct-1) THEN - ! x5 = -piq - !ENDIF - - y1 = fcubehalo(i,j-2,p) - y2 = fcubehalo(i,j-1,p) - y3 = fcubehalo(i,j,p) - y4 = fcubehalo(i,j+1,p) - y5 = fcubehalo(i,j+2,p) - - denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1 - denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2 - denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4 - denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5 - - t(1) = x5 * x4 * x2 - t(2) = x5 * x4 * x1 - t(4) = x5 * x2 * x1 - t(5) = x4 * x2 * x1 - t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5) - - pa(1) = x2 * x4 + x2 * x5 + x4 * x5 - pa(2) = x1 * x4 + x1 * x5 + x4 * x5 - pa(4) = x1 * x2 + x1 * x5 + x2 * x5 - pa(5) = x1 * x2 + x1 * x4 + x2 * x4 - pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5) - - recons(2,i,j,p) = & - + y1 * t(1) / denom(1) & - + y2 * t(2) / denom(2) & - - y3 * t(3) & - + y4 * t(4) / denom(4) & - + y5 * t(5) / denom(5) - - IF (order > 2) THEN - recons(4,i,j,p) = & - - y1 * pa(1) / denom(1) & - - y2 * pa(2) / denom(2) & - + y3 * pa(3) & - - y4 * pa(4) / denom(4) & - - y5 * pa(5) / denom(5) - recons(5,i,j,p) = 0.0 - ENDIF - - ENDDO - ENDDO - IF (order > 2) THEN - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - x1 = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1) - x2 = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1) - - y2 = (+ fcubehalo(i-1,j+1,p) * x2**2 & - - fcubehalo(i+1,j+1,p) * x1**2 & - - fcubehalo(i,j+1,p) * (x2**2 - x1**2)) / & - (x2 * x1 * (x2 - x1)) - - x1 = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1) - x2 = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1) - - y1 = (+ fcubehalo(i-1,j-1,p) * x2**2 & - - fcubehalo(i+1,j-1,p) * x1**2 & - - fcubehalo(i,j-1,p) * (x2**2 - x1**2)) / & - (x2 * x1 * (x2 - x1)) - - x1 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - x2 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(5,i,j,p) = & - (+ y1 * x2**2 & - - y2 * x1**2 & - - recons(1,i,j,p) * (x2**2 - x1**2)) / & - (x2 * x1 * (x2 - x1)) - - ENDDO - ENDDO - ENDIF - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_PLM -! -! Description: -! Construct a piecewise linear reconstruction of the gradient within -! each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_PLM(fcubehalo, recons, order) - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: width - - ! ABP width between elements - width = pih / DBLE(ncube_reconstruct-1) - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - ! df/dx - recons(1,i,j,p) = (fcubehalo(i+1,j,p) - fcubehalo(i-1,j,p)) / & - (2.0 * width) - - ! df/dy - recons(2,i,j,p) = (fcubehalo(i,j+1,p) - fcubehalo(i,j-1,p)) / & - (2.0 * width) - - ! Stretching - recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2) - recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2) - - ! Third order scheme - IF (order > 2) THEN - ! d^2f/dx^2 - recons(3,i,j,p) = & - (fcubehalo(i+1,j,p) - 2.0 * fcubehalo(i,j,p) & - + fcubehalo(i-1,j,p)) / (width * width) - - ! d^2f/dy^2 - recons(4,i,j,p) = & - (fcubehalo(i,j+1,p) - 2.0 * fcubehalo(i,j,p) & - + fcubehalo(i,j-1,p)) / (width * width) - - ! d^2f/dxdy - recons(5,i,j,p) = & - (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) & - - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) & - ) / (4.0 * width * width) - - ! Stretching - recons(3,i,j,p) = & - (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) & - + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2 - - recons(4,i,j,p) = & - (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) & - + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2 - - recons(5,i,j,p) = recons(5,i,j,p) / & - ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2)) - - ! Scaling - recons(3,i,j,p) = 0.5 * recons(3,i,j,p) - recons(4,i,j,p) = 0.5 * recons(4,i,j,p) - - ENDIF - ENDDO - ENDDO - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_PPM -! -! Description: -! Construct a piecewise parabolic reconstruction of the gradient within -! each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_PPM(fcubehalo, recons, order) - - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: width - - ! ABP width between elements - width = pih / DBLE(ncube_reconstruct-1) - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - ! df/dalfa - recons(1,i,j,p) = & - (+ fcubehalo(i+2,j,p) - 8.0 * fcubehalo(i+1,j,p) & - + 8.0 * fcubehalo(i-1,j,p) - fcubehalo(i-2,j,p)) / & - (- 12.0 * width) - - ! df/dbeta - recons(2,i,j,p) = & - (+ fcubehalo(i,j+2,p) - 8.0 * fcubehalo(i,j+1,p) & - + 8.0 * fcubehalo(i,j-1,p) - fcubehalo(i,j-2,p)) / & - (- 12.0 * width) - - ! Stretching - recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2) - recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2) - - ! Third order scheme - IF (order > 2) THEN - ! d^2f/dx^2 - recons(3,i,j,p) = (- fcubehalo(i+2,j,p) & - + 16_dbl_kind * fcubehalo(i+1,j,p) & - - 30_dbl_kind * fcubehalo(i,j,p) & - + 16_dbl_kind * fcubehalo(i-1,j,p) & - - fcubehalo(i-2,j,p) & - ) / (12_dbl_kind * width**2) - - ! d^2f/dy^2 - recons(4,i,j,p) = (- fcubehalo(i,j+2,p) & - + 16_dbl_kind * fcubehalo(i,j+1,p) & - - 30_dbl_kind * fcubehalo(i,j,p) & - + 16_dbl_kind * fcubehalo(i,j-1,p) & - - fcubehalo(i,j-2,p) & - ) / (12_dbl_kind * width**2) - - ! d^2f/dxdy - recons(5,i,j,p) = & - (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) & - - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) & - ) / (4.0 * width * width) - - ! Stretching - recons(3,i,j,p) = & - (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) & - + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2 - - recons(4,i,j,p) = & - (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) & - + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2 - - recons(5,i,j,p) = recons(5,i,j,p) / & - ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2)) - - ! Scaling - recons(3,i,j,p) = 0.5 * recons(3,i,j,p) - recons(4,i,j,p) = 0.5 * recons(4,i,j,p) - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient -! -! Description: -! Compute the reconstructed gradient in gnomonic coordinates for each -! ABP element. -! -! Parameters: -! fcube - Scalar field on the cubed sphere to use in reconstruction -! halomethod - Method for computing halo elements -! (0) Piecewise constant -! (1) Piecewise linear -! (3) Piecewise cubic -! recons_method - Method for computing the sub-grid scale gradient -! (0) Non-equidistant linear reconstruction -! (1) Non-equidistant parabolic reconstruction -! (2) Piecewise linear reconstruction with stretching -! (3) Piecewise parabolic reconstruction with stretching -! order - Order of the method being applied -! kmono - Apply monotone limiting (1) or not (0) -! recons (INOUT) - Array of reconstructed coefficients -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient( & - fcube, halomethod, recons_method, order, kmono, recons, kpd, kscheme) - -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(1:ncube_reconstruct-1, 1:ncube_reconstruct-1, 6), INTENT(IN) :: fcube - - INTEGER (KIND=int_kind), INTENT(IN) :: halomethod, recons_method - INTEGER (KIND=int_kind), INTENT(IN) :: order, kmono, kpd, kscheme - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: fcubehalo - - ! Report status - WRITE (*,*) '...Performing sub-grid scale reconstruction on ABP grid' - - ! Compute element haloes - WRITE(*,*) "fill cubed-sphere halo for reconstruction" - DO p = 1, 6 - IF (halomethod == 0) THEN - CALL CubedSphereFillHalo(fcube, fcubehalo, p, ncube_reconstruct, 2) - - ELSEIF (halomethod == 1) THEN - CALL CubedSphereFillHalo_Linear(fcube, fcubehalo, p, ncube_reconstruct) - - ELSEIF (halomethod == 3) THEN - !halomethod is always 3 in the standard CSLAM setup - CALL CubedSphereFillHalo_Cubic(fcube, fcubehalo, p, ncube_reconstruct) - ELSE - WRITE (*,*) 'Fatal Error: In ReconstructABPGradient' - WRITE (*,*) 'Invalid halo method: ', halomethod - WRITE (*,*) 'Halo method must be 0, 1 or 3.' - STOP - ENDIF - ENDDO - - ! Nonequidistant linear reconstruction - IF (recons_method == 1) THEN - CALL ReconstructABPGradient_NEL(fcubehalo, recons, order) - - ! Nonequidistant parabolic reconstruction (JCP paper) - ELSEIF (recons_method == 2) THEN - WRITE(*,*) "Nonequidistant parabolic reconstruction" - CALL ReconstructABPGradient_NEP(fcubehalo, recons, order) - - ! Piecewise linear reconstruction with rotation - ELSEIF (recons_method == 3) THEN - CALL ReconstructABPGradient_PLM(fcubehalo, recons, order) - - ! Piecewise parabolic reconstruction with rotation - ELSEIF (recons_method == 4) THEN - CALL ReconstructABPGradient_PPM(fcubehalo, recons, order) - - ELSE - WRITE(*,*) 'Fatal Error: In ReconstructABPGradient' - WRITE(*,*) 'Specified recons_method out of range. Given: ', recons_method - WRITE(*,*) 'Valid values: 1, 2, 3, 4' - STOP - ENDIF - - ! Apply monotone filtering - SELECT CASE (kmono) - CASE (0) !Do nothing - WRITE(*,*) "no filter applied to the reconstruction" - CASE (1) - - !Simplest filter: just scales the recon so it's extreme value - !is no bigger than the original values of this point and its neighbors - CALL MonotonizeABPGradient(fcubehalo, order, recons, .FALSE.) - - CASE (2) - - !Applies a more sophisticated Van Leer limiter (or, to be consistent, a filter) - CALL VanLeerLimit(fcubehalo, order, recons) - - CASE (3) - - !Applies a selective filter - CALL MonotonizeABPGradient(fcubehalo, order, recons, .TRUE.) - - CASE (4) - - !A filter that filters the linear part first - CALL MonotonizeABPGradient_New(fcubehalo, order, recons) - - CASE DEFAULT - WRITE(*,*) "Limiter kmono = ", kmono, " does not exist." - STOP 1201 - - END SELECT - - !Apply positive-definite filtering, if desired. This should - !ONLY be applied to the S-L method, since the flux-form - !method needs something different done. (In particular, using - !positive-definite reconstructions does not ensure that a flux- - !form scheme is positive definite, since we could get negatives - !when subtracting the resulting fluxes.) - !HOWEVER...we will allow this to be enabled, for testing purposes - IF ( (kpd > 0 .AND. kscheme == 2) .OR. (kpd == 2 .AND. kscheme == 4) ) THEN - WRITE(*,*) "applying positive deifnite constraint" - CALL PosDefABPGradient(fcubehalo, order, recons) - END IF - - - END SUBROUTINE - - - -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -! SUBROUTINE AdjustLimiter -! -! Description: -! Adjust the slope limiter based on new point values. -! -! Parameters: -! value - Point value -! element_value - Value at the center of the element -! local_max - Local maximum value of the function (from neighbours) -! local_min - Local minimum value of the function (to neighbours) -! min_phi (INOUT) - Slope limiter -!------------------------------------------------------------------------------ - SUBROUTINE AdjustLimiter(value, element_value, local_min, local_max, min_phi) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), INTENT(IN) :: value, element_value - REAL (KIND=dbl_kind), INTENT(IN) :: local_min, local_max - REAL (KIND=dbl_kind), INTENT(INOUT) :: min_phi - - ! Local variables - REAL (KIND=dbl_kind) :: phi = 0.0 - - IF ((local_min > element_value ) .OR. (local_max < element_value )) THEN - WRITE (*,*) 'Fatal Error: In AdjustLimiter' - WRITE (*,*) 'Local min: ', local_min, ' max: ', local_max - WRITE (*,*) 'Elemn: ', element_value - STOP - ENDIF - - ! Check against the minimum bound on the reconstruction - IF (value - element_value > tiny * value) THEN - phi = (local_max - element_value) / & - (value - element_value) - - min_phi = MIN(min_phi, phi) - - ! Check against the maximum bound on the reconstruction - ELSEIF (value - element_value < -tiny * value) THEN - phi = (local_min - element_value) / & - (value - element_value) - - min_phi = MIN(min_phi, phi) - - ENDIF - - IF (min_phi < 0.0) THEN - WRITE (*,*) 'Fatal Error: In AdjustLimiter' - WRITE (*,*) 'Min_Phi: ', min_phi - WRITE (*,*) 'Phi: ', phi - WRITE (*,*) 'Value: ', value - WRITE (*,*) 'Elemn: ', element_value - WRITE (*,*) 'Val-E: ', value - element_value - STOP - ENDIF - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE VanLeerLimit -! -! Description: -! Apply a 2D Van Leer-type limiter to a reconstruction. This acts ONLY -! on the linear part of the reconstruction , if any. If passed a PCoM -! reconstruction, this just returns without altering the recon. -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! -! Remarks: -! The Van Leer Limiter described here is given on pages 328--329 -! of Dukowicz and Baumgardner (2000). There are no guarantees -! on what it will do to PPM. -!------------------------------------------------------------------------------ - SUBROUTINE VanLeerLimit(fcubehalo, order, recons) - - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, & - recon_min, recon_max - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element. For the Van Leer limiter, we - !wish to find BOTH of the reconstruction extrema. - recon_min = bignum - recon_max = -bignum - - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) - recon_min = MIN(recon_min, value) - recon_max = MAX(recon_max, value) - - ENDDO - ENDDO - - !This is equation 27 in Dukowicz and Baumgardner 2000 - min_phi = MIN(one, MAX(0.0, (local_min - fcubehalo(i,j,k))/(recon_min - fcubehalo(i,j,k))), & - MAX(0.0, (local_max - fcubehalo(i,j,k))/(recon_max - fcubehalo(i,j,k))) ) - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - ! Apply monotone limiter to all reconstruction coefficients - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - END DO - END DO - END DO - - - - - END SUBROUTINE VanLeerLimit - - !------------------------------------------------------------------------------ - ! SUBROUTINE EquiangularElementArea - ! - ! Description: - ! Compute the area of a single equiangular cubed sphere grid cell. - ! - ! Parameters: - ! alpha - Alpha coordinate of lower-left corner of grid cell - ! da - Delta alpha - ! beta - Beta coordinate of lower-left corner of grid cell - ! db - Delta beta - !------------------------------------------------------------------------------ - REAL(KIND=dbl_kind) FUNCTION EquiangularElementArea(alpha, da, beta, db) - - IMPLICIT NONE - -! REAL (kind=dbl_kind) :: EquiangularElementArea - REAL (kind=dbl_kind) :: alpha, da, beta, db - REAL (kind=dbl_kind) :: a1, a2, a3, a4 - - ! Calculate interior grid angles - a1 = EquiangularGridAngle(alpha , beta ) - a2 = pi - EquiangularGridAngle(alpha+da, beta ) - a3 = pi - EquiangularGridAngle(alpha , beta+db) - a4 = EquiangularGridAngle(alpha+da, beta+db) - - ! Area = r*r*(-2*pi+sum(interior angles)) - EquiangularElementArea = -pi2 + a1 + a2 + a3 + a4 - - END FUNCTION EquiangularElementArea - - !------------------------------------------------------------------------------ - ! FUNCTION EquiangularGridAngle - ! - ! Description: - ! Compute the angle between equiangular cubed sphere projection grid lines. - ! - ! Parameters: - ! alpha - Alpha coordinate of evaluation point - ! beta - Beta coordinate of evaluation point - !------------------------------------------------------------------------------ - REAL(KIND=dbl_kind) FUNCTION EquiangularGridAngle(alpha, beta) - IMPLICIT NONE - REAL (kind=dbl_kind) :: alpha, beta - EquiangularGridAngle = ACOS(-SIN(alpha) * SIN(beta)) - END FUNCTION EquiangularGridAngle - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereFillHalo -! -! Description: -! Recompute the cubed sphere data storage array, with the addition of a -! halo region around the specified panel. -! -! Parameters: -! parg - Current panel values -! zarg (OUT) - Calculated panel values with halo/ghost region -! np - Panel number -! ncube - Dimension of the cubed sphere (# of grid lines) -! nhalo - Number of halo/ghost elements around each panel -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereFillHalo(parg, zarg, np, ncube, nhalo) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & - INTENT(OUT) :: zarg - - INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube,nhalo - - ! Local variables - INTEGER (KIND=int_kind) :: jh,jhy - - !zarg = 0.0 !DBG - zarg(1:ncube-1,1:ncube-1,np) = parg(1:ncube-1,1:ncube-1,np) - - zarg(1-nhalo:0,1-nhalo:0,np) = 0.0 - zarg(1-nhalo:0,ncube:ncube+nhalo-1,np) = 0.0 - zarg(ncube:ncube+nhalo-1,1-nhalo:0,np) = 0.0 - zarg(ncube:ncube+nhalo-1,ncube:ncube+nhalo-1,np) = 0.0 - - ! Equatorial panels - IF (np==1) THEN - DO jh=1,nhalo - zarg(ncube+jh-1,1:ncube-1 ,1) = parg(jh ,1:ncube-1 ,2) !exchange right - zarg(1-jh ,1:ncube-1 ,1) = parg(ncube-jh ,1:ncube-1 ,4) !exchange left - zarg(1:ncube-1 ,1-jh ,1) = parg(1:ncube-1 ,ncube-jh ,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,1) = parg(1:ncube-1 ,jh ,6) !exchange over - ENDDO - - ELSE IF (np==2) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,2) = parg(ncube-jh,1:ncube-1 ,1) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,2) = parg(jh ,1:ncube-1 ,3) !exchange right - zarg(1:ncube-1 ,1-jh ,2) = parg(ncube-jh,ncube-1:1:-1,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,2) = parg(ncube-jh,1:ncube-1 ,6) !exchange over - ENDDO - - ELSE IF (np==3) THEN - DO jh=1,nhalo - zarg(ncube+jh-1,1:ncube-1 ,3) = parg(jh ,1:ncube-1,4) !exchange right - zarg(1-jh ,1:ncube-1 ,3) = parg(ncube-jh ,1:ncube-1,2) !exchange left - zarg(1:ncube-1 ,1-jh ,3) = parg(ncube-1:1:-1,jh ,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,3) = parg(ncube-1:1:-1,ncube-jh ,6) !exchange over - ENDDO - - ELSE IF (np==4) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,4) = parg(ncube-jh,1:ncube-1 ,3) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,4) = parg(jh ,1:ncube-1 ,1) !exchange right - zarg(1:ncube-1 ,1-jh ,4) = parg(jh ,1:ncube-1 ,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,4) = parg(jh ,ncube-1:1:-1,6) !exchange over - ENDDO - - ! Bottom panel - ELSE IF (np==5) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,5) = parg(1:ncube-1 ,jh ,4) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,5) = parg(ncube-1:1:-1,jh ,2) !exchange right - zarg(1:ncube-1 ,1-jh ,5) = parg(ncube-1:1:-1,jh ,3) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,5) = parg(1:ncube-1 ,jh ,1) !exchange over - ENDDO - - ! Top panel - ELSE IF (np==6) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,6) = parg(ncube-1:1:-1,ncube-jh,4) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,6) = parg(1:ncube-1 ,ncube-jh,2) !exchange right - zarg(1:ncube-1 ,1-jh ,6) = parg(1:ncube-1 ,ncube-jh,1) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,6) = parg(ncube-1:1:-1,ncube-jh,3) !exchange over - ENDDO - - ELSE - WRITE (*,*) 'Fatal error: In CubedSphereFillHalo' - WRITE (*,*) 'Invalid panel id ', np - STOP - ENDIF - - END SUBROUTINE CubedSphereFillHalo - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereFillHalo_Linear -! -! Description: -! Recompute the cubed sphere data storage array, with the addition of a -! 2-element halo region around the specified panel. Use linear order -! interpolation to translate between panels. -! -! Parameters: -! parg - Current panel values -! zarg (OUT) - Calculated panel values with halo/ghost region -! np - Panel number -! ncube - Dimension of the cubed sphere (# of grid lines) -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereFillHalo_Linear(parg, zarg, np, ncube) - -! USE CubedSphereTrans ! Cubed sphere transforms - - IMPLICIT NONE - - INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2 - - REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & - INTENT(OUT) :: zarg - - INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube - - ! Local variables - INTEGER (KIND=int_kind) :: ii, iref, jj, ipanel, imin, imax - REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta - - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg - - ! Use 0.0 order interpolation to begin - CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo) - - zarg(:,:,np) = yarg(:,:,np) - - ! Calculate the overlapping alpha coordinates - width = pih / DBLE(ncube-1) - - DO jj = 1, nhalo - DO ii = 0, ncube - prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq - beta = - width * (DBLE(jj-1) + 0.5) - piq - - CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, & - newalpha(ii,jj), newbeta) - ENDDO - ENDDO - - ! Now apply linear interpolation to obtain edge components - DO jj = 1, nhalo - ! Reset the reference index - iref = 2 - - ! Interpolation can be applied to more elements after first band - IF (jj == 1) THEN - imin = 1 - imax = ncube-1 - ELSE - imin = 0 - imax = ncube - ENDIF - - ! Apply linear interpolation - DO ii = imin, imax - DO WHILE ((iref .NE. ncube-1) .AND. & - (newalpha(ii,jj) > prealpha(iref,jj))) - iref = iref + 1 - ENDDO - - IF ((newalpha(ii,jj) > prealpha(iref-1,jj)) .AND. & - (newalpha(ii,jj) .LE. prealpha(iref ,jj))) & - THEN - a = (newalpha(ii,jj) - prealpha(iref-1,jj)) / & - (prealpha(iref,jj) - prealpha(iref-1,jj)) - - IF ((a < 0.0) .OR. (a > one)) THEN - WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear' - WRITE (*,*) 'a out of bounds' - STOP - ENDIF - - ! Bottom edge of panel - zarg(ii, 1-jj, np) = & - (one - a) * yarg(iref-1, 1-jj, np) + & - a * yarg(iref, 1-jj, np) - - ! Left edge of panel - zarg(1-jj, ii, np) = & - (one - a) * yarg(1-jj, iref-1, np) + & - a * yarg(1-jj, iref, np) - - ! Top edge of panel - zarg(ii, ncube+jj-1, np) = & - (one - a) * yarg(iref-1, ncube+jj-1, np) + & - a * yarg(iref, ncube+jj-1, np) - - ! Right edge of panel - zarg(ncube+jj-1, ii, np) = & - (one - a) * yarg(ncube+jj-1, iref-1, np) + & - a * yarg(ncube+jj-1, iref, np) - - ELSE - WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear' - WRITE (*,*) 'ii: ', ii, ' jj: ', jj - WRITE (*,*) 'newalpha: ', newalpha(ii,jj) - WRITE (*,*) 'prealpha: ', prealpha(iref-1,jj), '-', prealpha(iref,jj) - STOP - ENDIF - ENDDO - ENDDO - - ! Fill in corner bits - zarg(0, 0, np) = & - 0.25 * (zarg(1,0,np) + zarg(0,1,np) + & - zarg(-1,0,np) + zarg(0,-1,np)) - zarg(0, ncube, np) = & - 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + & - zarg(-1,ncube,np) + zarg(1,ncube,np)) - zarg(ncube, 0, np) = & - 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + & - zarg(ncube,-1,np) + zarg(ncube,1,np)) - zarg(ncube, ncube, np) = & - 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + & - zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np)) - - END SUBROUTINE CubedSphereFillHalo_Linear - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereFillHalo_Cubic -! -! Description: -! Recompute the cubed sphere data storage array, with the addition of a -! 2-element halo region around the specified panel. Use higher order -! interpolation to translate between panels. -! -! Parameters: -! parg - Current panel values -! zarg (OUT) - Calculated panel values with halo/ghost region -! np - Panel number -! ncube - Dimension of the cubed sphere (# of grid lines) -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereFillHalo_Cubic(parg, zarg, np, ncube) - -! USE CubedSphereTrans ! Cubed sphere transforms -! USE MathUtils ! Has function for 1D cubic interpolation - - IMPLICIT NONE - - INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2 - - REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & - INTENT(OUT) :: zarg - - INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube - - ! Local variables - INTEGER (KIND=int_kind) :: ii, iref, ibaseref, jj, ipanel, imin, imax - REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta - - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha - REAL (KIND=dbl_kind), DIMENSION(1:4) :: C, D, X - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg - - ! Use 0.0 order interpolation to begin - CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo) - - zarg(:,:,np) = yarg(:,:,np) - - ! Calculate the overlapping alpha coordinates - width = pih / DBLE(ncube-1) - - DO jj = 1, nhalo - DO ii = 0, ncube - ! - ! alpha,beta for the cell center (extending the panel) - ! - prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq - beta = - width * (DBLE(jj-1) + 0.5) - piq - - CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, & - newalpha(ii,jj), newbeta) - ENDDO - ENDDO - - ! Now apply cubic interpolation to obtain edge components - DO jj = 1, nhalo - ! Reset the reference index, which gives the element in newalpha that - ! is closest to ii, looking towards larger values of alpha. - iref = 2 - - ! Interpolation can be applied to more elements after first band -! IF (jj == 1) THEN -! imin = 1 -! imax = ncube-1 -! ELSE - imin = 0 - imax = ncube -! ENDIF - - ! Apply cubic interpolation - DO ii = imin, imax - DO WHILE ((iref .NE. ncube-1) .AND. & - (newalpha(ii,jj) > prealpha(iref,jj))) - iref = iref + 1 - ENDDO - - ! Smallest index for cubic interpolation - apply special consideration - IF (iref == 2) THEN - ibaseref = iref-1 - - ! Largest index for cubic interpolation - apply special consideration - ELSEIF (iref == ncube-1) THEN - ibaseref = iref-3 - - ! Normal range - ELSE - ibaseref = iref-2 - ENDIF - - ! Bottom edge of panel - zarg(ii, 1-jj, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(ibaseref:ibaseref+3, 1-jj, np)) - - ! Left edge of panel - zarg(1-jj, ii, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(1-jj, ibaseref:ibaseref+3, np)) - - ! Top edge of panel - zarg(ii, ncube+jj-1, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(ibaseref:ibaseref+3, ncube+jj-1, np)) - - ! Right edge of panel - zarg(ncube+jj-1, ii, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(ncube+jj-1, ibaseref:ibaseref+3, np)) - - ENDDO - ENDDO - - ! Fill in corner bits - zarg(0, 0, np) = & - 0.25 * (zarg(1,0,np) + zarg(0,1,np) + & - zarg(-1,0,np) + zarg(0,-1,np)) - zarg(0, ncube, np) = & - 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + & - zarg(-1,ncube,np) + zarg(1,ncube,np)) - zarg(ncube, 0, np) = & - 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + & - zarg(ncube,-1,np) + zarg(ncube,1,np)) - zarg(ncube, ncube, np) = & - 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + & - zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np)) - - END SUBROUTINE CubedSphereFillHalo_Cubic - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereABPFromABP -! -! Description: -! Determine the (alpha,beta,idest) coordinate of a source point on -! panel isource. -! -! Parameters: -! alpha_in - Alpha coordinate in -! beta_in - Beta coordinate in -! isource - Source panel -! idest - Destination panel -! alpha_out (OUT) - Alpha coordinate out -! beta_out (OUT) - Beta coordiante out -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereABPFromABP(alpha_in, beta_in, isource, idest, & - alpha_out, beta_out) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), INTENT(IN) :: alpha_in, beta_in - INTEGER (KIND=int_kind), INTENT(IN) :: isource, idest - REAL (KIND=dbl_kind), INTENT(OUT) :: alpha_out, beta_out - - ! Local variables - REAL (KIND=dbl_kind) :: a1, b1 - REAL (KIND=dbl_kind) :: xx, yy, zz - REAL (KIND=dbl_kind) :: sx, sy, sz - - ! Convert to relative Cartesian coordinates - a1 = TAN(alpha_in) - b1 = TAN(beta_in) - - sz = (one + a1 * a1 + b1 * b1)**(-0.5) - sx = sz * a1 - sy = sz * b1 - - ! Convert to full Cartesian coordinates - IF (isource == 6) THEN - yy = sx; xx = -sy; zz = sz - - ELSEIF (isource == 5) THEN - yy = sx; xx = sy; zz = -sz - - ELSEIF (isource == 1) THEN - yy = sx; zz = sy; xx = sz - - ELSEIF (isource == 3) THEN - yy = -sx; zz = sy; xx = -sz - - ELSEIF (isource == 2) THEN - xx = -sx; zz = sy; yy = sz - - ELSEIF (isource == 4) THEN - xx = sx; zz = sy; yy = -sz - - ELSE - WRITE(*,*) 'Fatal Error: Source panel invalid in CubedSphereABPFromABP' - WRITE(*,*) 'panel = ', isource - STOP - ENDIF - - ! Convert to relative Cartesian coordinates on destination panel - IF (idest == 6) THEN - sx = yy; sy = -xx; sz = zz - - ELSEIF (idest == 5) THEN - sx = yy; sy = xx; sz = -zz - - ELSEIF (idest == 1) THEN - sx = yy; sy = zz; sz = xx - - ELSEIF (idest == 3) THEN - sx = -yy; sy = zz; sz = -xx - - ELSEIF (idest == 2) THEN - sx = -xx; sy = zz; sz = yy - - ELSEIF (idest == 4) THEN - sx = xx; sy = zz; sz = -yy - - ELSE - WRITE(*,*) 'Fatal Error: Dest panel invalid in CubedSphereABPFromABP' - WRITE(*,*) 'panel = ', idest - STOP - ENDIF - IF (sz < 0) THEN - WRITE(*,*) 'Fatal Error: In CubedSphereABPFromABP' - WRITE(*,*) 'Invalid relative Z coordinate' - STOP - ENDIF - - ! Use panel information to calculate (alpha, beta) coords - alpha_out = ATAN(sx / sz) - beta_out = ATAN(sy / sz) - - END SUBROUTINE - - -!------------------------------------------------------------------------------ -! FUNCTION CUBIC_EQUISPACE_INTERP -! -! Description: -! Apply cubic interpolation on the specified array of values, where all -! points are equally spaced. -! -! Parameters: -! dx - Spacing of points -! x - X coordinate where interpolation is to be applied -! y - Array of 4 values = f(x + k * dx) where k = 0,1,2,3 -!------------------------------------------------------------------------------ - FUNCTION CUBIC_EQUISPACE_INTERP(dx, x, y) - - IMPLICIT NONE - - REAL (KIND=dbl_kind) :: CUBIC_EQUISPACE_INTERP - REAL (KIND=dbl_kind) :: dx, x - REAL (KIND=dbl_kind), DIMENSION(1:4) :: y - - CUBIC_EQUISPACE_INTERP = & - (-y(1) / (6.0 * dx**3)) * (x - dx) * (x - 2.0 * dx) * (x - 3.0 * dx) + & - ( y(2) / (2.0 * dx**3)) * (x) * (x - 2.0 * dx) * (x - 3.0 * dx) + & - (-y(3) / (2.0 * dx**3)) * (x) * (x - dx) * (x - 3.0 * dx) + & - ( y(4) / (6.0 * dx**3)) * (x) * (x - dx) * (x - 2.0 * dx) - - END FUNCTION CUBIC_EQUISPACE_INTERP - -! FUNCTION I_10_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind) :: I_10_AB -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! I_10_ab = -ASINH(COS(alpha) * TAN(beta)) -! END FUNCTION I_10_AB -!! -! -! REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! I_01_ab = -ASINH(COS(beta) * TAN(alpha)) -! END FUNCTION I_01_AB -! -! REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! -! I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta)) -! END FUNCTION I_20_AB -! -! REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! -! I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta)) -! END FUNCTION I_02_AB -! -! REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! -! I_11_ab = -SQRT(1.0+TAN(alpha)**2+TAN(beta)**2) -! END FUNCTION I_11_AB -! - - -END MODULE reconstruct - diff --git a/tools/topo_tool/cube_to_target/remap.F90 b/tools/topo_tool/cube_to_target/remap.F90 deleted file mode 100644 index b56b7fd493..0000000000 --- a/tools/topo_tool/cube_to_target/remap.F90 +++ /dev/null @@ -1,1561 +0,0 @@ -MODULE remap - INTEGER, PARAMETER :: & - int_kind = KIND(1), & - real_kind = SELECTED_REAL_KIND(p=14,r=100),& - dbl_kind = selected_real_kind(13) - - INTEGER :: nc,nhe - -! LOGICAL, PARAMETER:: ldbgr_r = .FALSE. - LOGICAL :: ldbgr - LOGICAL :: ldbg_global - - REAL(kind=real_kind), PARAMETER :: & - one = 1.0 ,& - aa = 1.0 ,& - tiny= 1.0E-9 ,& - bignum = 1.0E20 - REAL (KIND=dbl_kind), parameter :: fuzzy_width = 10.0*tiny !CAM-SE add - - contains - - - subroutine compute_weights_cell(xcell_in,ycell_in,jx,jy,nreconstruction,xgno,ygno,& - jx_min, jx_max, jy_min, jy_max,tmp,& - ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,& - nc_in,nhe_in,nvertex,ldbg) - - implicit none - integer (kind=int_kind) , intent(in):: nreconstruction, jx,jy,ngauss,jmax_segments - real (kind=real_kind) , dimension(0:nvertex+1) :: xcell_in,ycell_in -! real (kind=real_kind) , dimension(0:5), intent(in):: xcell_in,ycell_in - integer (kind=int_kind), intent(in) :: nc_in,nhe_in,nvertex - logical, intent(in) :: ldbg - ! - ! ipanel is just for debugging - ! - integer (kind=int_kind), intent(in) :: jx_min, jy_min, jx_max, jy_max - real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: xgno - real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: ygno - ! - ! for Gaussian quadrature - ! - real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae - ! - ! boundaries of domain - ! - real (kind=real_kind):: tmp - ! - ! Number of Eulerian sub-cell integrals for the cell in question - ! - integer (kind=int_kind), intent(out) :: jcollect - ! - ! local workspace - ! - ! - ! max number of line segments is: - ! - ! (number of longitudes)*(max average number of crossings per line segment = 3)*ncube*2 - ! - real (kind=real_kind) , & - dimension(jmax_segments,nreconstruction), intent(out) :: weights - integer (kind=int_kind), & - dimension(jmax_segments,2), intent(out) :: weights_eul_index - - real (kind=real_kind), dimension(0:3) :: x,y - integer (kind=int_kind),dimension(0:5) :: jx_eul, jy_eul - integer (kind=int_kind) :: jsegment,i - ! - ! variables for registering crossings with Eulerian latitudes and longitudes - ! - integer (kind=int_kind) :: jcross_lat, iter - ! - ! max. crossings per side is 2*nhe - ! - real (kind=real_kind), & - dimension(jmax_segments,2) :: r_cross_lat - integer (kind=int_kind), & - dimension(jmax_segments,2) :: cross_lat_eul_index - real (kind=real_kind) , dimension(1:nvertex) :: xcell,ycell - - real (kind=real_kind) :: eps - - ldbg_global = ldbg - ldbgr = ldbg - - nc = nc_in - nhe = nhe_in - - xcell = xcell_in(1:nvertex) - ycell = ycell_in(1:nvertex) - - - ! - ! this is to avoid ill-conditioning problems - ! - eps = 1.0E-9 - - jsegment = 0 - weights = 0.0D0 - jcross_lat = 0 - ! - !********************** - ! - ! Integrate cell sides - ! - !********************** - - - IF (jx<-nhe.OR.jx>nc+1+nhe.OR.jy<-nhe.OR.jy>nc+1+nhe) THEN - WRITE(*,*) "jx,jy,-nhe,nc+1+nhe",jx,jy,-nhe,nc+1+nhe - STOP - END IF - - - call side_integral(xcell,ycell,nvertex,jsegment,jmax_segments,& - weights,weights_eul_index,nreconstruction,jx,jy,xgno,ygno,jx_min, jx_max, jy_min, jy_max,& - ngauss,gauss_weights,abscissae,& - jcross_lat,r_cross_lat,cross_lat_eul_index) - - ! - !********************** - ! - ! Do inner integrals - ! - !********************** - ! - call compute_inner_line_integrals_lat_nonconvex(r_cross_lat,cross_lat_eul_index,& - jcross_lat,jsegment,jmax_segments,xgno,jx_min, jx_max, jy_min, jy_max,& - weights,weights_eul_index,& - nreconstruction,ngauss,gauss_weights,abscissae) - ! - ! collect line-segment that reside in the same Eulerian cell - ! - if (jsegment>0) then - call collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments) - ! - ! DBG - ! - tmp=0.0 - do i=1,jcollect - tmp=tmp+weights(i,1) - enddo - - IF (abs(tmp)>0.01) THEN - WRITE(*,*) "sum of weights too large",tmp - stop - END IF - IF (tmp<-1.0E-9) THEN - WRITE(*,*) "sum of weights is negative - negative area?",tmp,jx,jy - ! ldbgr=.TRUE. - stop - END IF - else - jcollect = 0 - end if - end subroutine compute_weights_cell - - - ! - !**************************************************************************** - ! - ! organize data and store it - ! - !**************************************************************************** - ! - subroutine collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments) - implicit none - integer (kind=int_kind) , intent(in) :: nreconstruction - real (kind=real_kind) , dimension(jmax_segments,nreconstruction), intent(inout) :: weights - integer (kind=int_kind), dimension(jmax_segments,2 ), intent(inout) :: weights_eul_index - integer (kind=int_kind), INTENT(OUT ) :: jcollect - integer (kind=int_kind), INTENT(IN ) :: jsegment,jmax_segments - ! - ! local workspace - ! - integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k,h - logical :: ltmp - - real (kind=real_kind) , dimension(jmax_segments,nreconstruction) :: weights_out - integer (kind=int_kind), dimension(jmax_segments,2 ) :: weights_eul_index_out - - weights_out = 0.0D0 - weights_eul_index_out = -100 - - imin = MINVAL(weights_eul_index(1:jsegment,1)) - imax = MAXVAL(weights_eul_index(1:jsegment,1)) - jmin = MINVAL(weights_eul_index(1:jsegment,2)) - jmax = MAXVAL(weights_eul_index(1:jsegment,2)) - - ltmp = .FALSE. - - jcollect = 1 - - do j=jmin,jmax - do i=imin,imax - do k=1,jsegment - if (weights_eul_index(k,1)==i.AND.weights_eul_index(k,2)==j) then - weights_out(jcollect,1:nreconstruction) = & - weights_out(jcollect,1:nreconstruction) + weights(k,1:nreconstruction) - ltmp = .TRUE. - h = k - endif - enddo - if (ltmp) then - weights_eul_index_out(jcollect,:) = weights_eul_index(h,:) - jcollect = jcollect+1 - endif - ltmp = .FALSE. - enddo - enddo - jcollect = jcollect-1 - weights = weights_out - weights_eul_index = weights_eul_index_out - end subroutine collect - ! - !***************************************************************************************** - ! - ! - ! - !***************************************************************************************** - ! - subroutine compute_inner_line_integrals_lat(r_cross_lat,cross_lat_eul_index,& - jcross_lat,jsegment,jmax_segments,xgno,jx_min,jx_max,jy_min, jy_max,weights,weights_eul_index,& - nreconstruction,ngauss,gauss_weights,abscissae)!phl add jx_min etc. - implicit none - ! - ! for Gaussian quadrature - ! - real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae - ! - ! variables for registering crossings with Eulerian latitudes and longitudes - ! - integer (kind=int_kind), intent(in):: jcross_lat, jmax_segments,nreconstruction,ngauss - integer (kind=int_kind), intent(inout):: jsegment - ! - ! max. crossings per side is 2*nhe - ! - real (kind=real_kind), & - dimension(jmax_segments,2), intent(in):: r_cross_lat - integer (kind=int_kind), & - dimension(jmax_segments,2), intent(in):: cross_lat_eul_index - integer (kind=int_kind), intent(in) ::jx_min, jx_max, jy_min, jy_max - real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: xgno - real (kind=real_kind) , & - dimension(jmax_segments,nreconstruction), intent(inout) :: weights - integer (kind=int_kind), & - dimension(jmax_segments,2), intent(inout) :: weights_eul_index - real (kind=real_kind) , dimension(nreconstruction) :: weights_tmp - - integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k, isgn, h, eul_jx, eul_jy - integer (kind=int_kind) :: idx_start_y,idx_end_y - logical :: ltmp,lcontinue - real (kind=real_kind), dimension(2) :: rstart,rend,rend_tmp - real (kind=real_kind), dimension(2) :: xseg, yseg -5 FORMAT(10e14.6) - - - if (jcross_lat>0) then - do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2)) - ! - ! find "first" crossing with Eulerian cell i - ! - do k=1,jcross_lat - if (cross_lat_eul_index(k,2)==i) exit - enddo - do j=k+1,jcross_lat - ! - ! find "second" crossing with Eulerian cell i - ! - if (cross_lat_eul_index(j,2)==i) then - if (r_cross_lat(k,1)0) then - do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2)) - ! WRITE(*,*) "looking at latitude ",i !xxxx - count = 1 - ! - ! find all crossings with Eulerian latitude i - ! - do k=1,jcross_lat - if (cross_lat_eul_index(k,2)==i) then - ! WRITE(*,*) "other crossings with latitude",i ," is ",k!xxxx - r_cross_lat_seg (count,:) = r_cross_lat (k,:) - cross_lat_eul_index_seg(count,:) = cross_lat_eul_index(k,:) - - IF (ldbg_global) then - WRITE(*,*) r_cross_lat_seg(count,1),r_cross_lat_seg(count,2) - WRITE(*,*) " " - END IF - count = count+1 - end if - enddo - count = count-1 - IF (ABS((count/2)-DBLE(count)/2.0)1000) THEN - WRITE(*,*) "search not converging",iter - STOP - END IF - lsame_cell_x = (x(2).GE.xgno(jx_eul).AND.x(2).LE.xgno(jx_eul+1)) - lsame_cell_y = (y(2).GE.ygno(jy_eul).AND.y(2).LE.ygno(jy_eul+1)) -! IF (ldbgr) WRITE(*,*) "lsame_cell_x,lsame_cell_y=",lsame_cell_x,lsame_cell_y - IF (lsame_cell_x.AND.lsame_cell_y) THEN - ! - !**************************** - ! - ! same cell integral - ! - !**************************** - ! -! IF (ldbgr) WRITE(*,*) "same cell integral",jx_eul,jy_eul - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = x(2); yseg(2) = y(2) - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - lcontinue = .FALSE. - ! - ! prepare for next side if (x(2),y(2)) is on a grid line - ! - IF (x(2).EQ.xgno(jx_eul+1).AND.x(3)>xgno(jx_eul+1)) THEN - ! - ! cross longitude jx_eul+1 - ! -! IF (ldbgr) WRITE(*,*) "cross longitude",jx_eul+1 - jx_eul=jx_eul+1 - ELSE IF (x(2).EQ.xgno(jx_eul ).AND.x(3)ygno(jy_eul+1)) THEN - ! - ! register crossing with latitude: line-segments point Northward - ! - jcross_lat = jcross_lat + 1 - jy_eul = jy_eul + 1 -! IF (ldbgr) WRITE(*,*) "cross latitude",jy_eul - cross_lat_eul_index(jcross_lat,1) = jx_eul - cross_lat_eul_index(jcross_lat,2) = jy_eul - r_cross_lat(jcross_lat,1) = x(2) - r_cross_lat(jcross_lat,2) = y(2) - ELSE IF (y(2).EQ.ygno(jy_eul ).AND.y(3)y(1) else "0" - ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1" - ! - !******************************************************************************* - ! - ! there is at least one crossing with latitudes but no crossing with longitudes - ! - !******************************************************************************* - ! - yeul = ygno(jy_eul+ysgn1) - IF (x(1).EQ.x(2)) THEN - ! - ! line segment is parallel to longitude (infinite slope) - ! -! IF (ldbgr) WRITE(*,*) "line segment parallel to longitude" - xcross = x(1) - ELSE - slope = (y(2)-y(1))/(x(2)-x(1)) - xcross = x_cross_eul_lat(x(1),y(1),yeul,slope) - ! - ! constrain crossing to be "physically" possible - ! - xcross = MIN(MAX(xcross,xgno(jx_eul)),xgno(jx_eul+1)) - - -! IF (ldbgr) WRITE(*,*) "cross latitude" - ! - ! debugging - ! - IF (xcross.GT.xgno(jx_eul+1).OR.xcross.LT.xgno(jx_eul)) THEN - WRITE(*,*) "xcross is out of range",jx,jy - WRITE(*,*) "xcross-xgno(jx_eul+1), xcross-xgno(jx_eul))",& - xcross-xgno(jx_eul+1), xcross-ygno(jx_eul) - STOP - END IF - END IF - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - ! - ! prepare for next iteration - ! - x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2 - ! - ! register crossing with latitude - ! - jcross_lat = jcross_lat+1 - cross_lat_eul_index(jcross_lat,1) = jx_eul - if (ysgn2>0) then - cross_lat_eul_index(jcross_lat,2) = jy_eul - else - cross_lat_eul_index(jcross_lat,2) = jy_eul+1 - end if - r_cross_lat(jcross_lat,1) = xcross - r_cross_lat(jcross_lat,2) = yeul - ELSE IF (lsame_cell_y) THEN -! IF (ldbgr) WRITE(*,*) "same cell y" - ! - !******************************************************************************* - ! - ! there is at least one crossing with longitudes but no crossing with latitudes - ! - !******************************************************************************* - ! - xsgn1 = (1+INT(SIGN(1.0D0,x(2)-x(1))))/2 !"1" if x(2)>x(1) else "0" - xsgn2 = INT(SIGN(1.0D0,x(2)-x(1))) !"1" if x(2)>x(1) else "-1" - xeul = xgno(jx_eul+xsgn1) -! IF (ldbgr) WRITE(*,*) " crossing longitude",jx_eul+xsgn1 - IF (ABS(x(2)-x(1))x(1) else "0" - xsgn2 = (INT(SIGN(1.0D0,x(2)-x(1)))) !"1" if x(2)>x(1) else "0" - xeul = xgno(jx_eul+xsgn1) - ysgn1 = (1+INT(SIGN(1.0D0,y(2)-y(1))))/2 !"1" if y(2)>y(1) else "0" - ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1" - yeul = ygno(jy_eul+ysgn1) - - slope = (y(2)-y(1))/(x(2)-x(1)) - IF (ABS(x(2)-x(1))0.AND.xcross.LE.xeul).OR.(xsgn2<0.AND.xcross.GE.xeul)) THEN - ! - ! cross latitude - ! -! IF (ldbgr) WRITE(*,*) "crossing latitude",jy_eul+ysgn1 - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - ! - ! prepare for next iteration - ! - x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2 - ! - ! register crossing with latitude - ! - jcross_lat = jcross_lat+1 - cross_lat_eul_index(jcross_lat,1) = jx_eul - if (ysgn2>0) then - cross_lat_eul_index(jcross_lat,2) = jy_eul - else - cross_lat_eul_index(jcross_lat,2) = jy_eul+1 - end if - r_cross_lat(jcross_lat,1) = xcross - r_cross_lat(jcross_lat,2) = yeul - ELSE - ! - ! cross longitude - ! -! IF (ldbgr) WRITE(*,*) "crossing longitude",jx_eul+xsgn1 - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xeul; yseg(2) = ycross - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - ! - ! prepare for next iteration - ! - x(0) = x(1); y(0) = y(1); x(1) = xeul; y(1) = ycross; jx_eul = jx_eul+xsgn2 - END IF - - END IF - END IF - ! - ! register line-segment (don't register line-segment if outside of panel) - ! - if (jx_eul_tmp>=jx_min.AND.jy_eul_tmp>=jy_min.AND.& - jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1) then - ! jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1.AND.side_count<3) then - jsegment=jsegment+1 - weights_eul_index(jsegment,1) = jx_eul_tmp - weights_eul_index(jsegment,2) = jy_eul_tmp - call get_weights_gauss(weights(jsegment,1:nreconstruction),& - xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae) - -! if (ldbg_global) then -! OPEN(unit=40, file='side_integral.dat',status='old',access='append') -! WRITE(40,*) xseg(1),yseg(1) -! WRITE(40,*) xseg(2),yseg(2) -! WRITE(40,*) " " -! CLOSE(40) -! end if - - - jdbg=jdbg+1 - - if (xseg(1).EQ.xseg(2))then - slope = bignum - else if (abs(yseg(1) -yseg(2))0) THEN - compute_slope = (y(2)-y(1))/(x(2)-x(1)) - else - compute_slope = bignum - end if - end function compute_slope - - real (kind=real_kind) function y_cross_eul_lon(x,y,xeul,slope) - implicit none - real (kind=real_kind), intent(in) :: x,y - real (kind=real_kind) , intent(in) :: xeul,slope - ! line: y=a*x+b - real (kind=real_kind) :: a,b - b = y-slope*x - y_cross_eul_lon = slope*xeul+b - end function y_cross_eul_lon - - real (kind=real_kind) function x_cross_eul_lat(x,y,yeul,slope) - implicit none - real (kind=real_kind), intent(in) :: x,y - real (kind=real_kind) , intent(in) :: yeul,slope - - if (fuzzy(ABS(slope),fuzzy_width)>0) THEN - x_cross_eul_lat = x+(yeul-y)/slope - ELSE - ! WRITE(*,*) "WARNING: slope is epsilon - ABORT" - x_cross_eul_lat = bignum - END IF - end function x_cross_eul_lat - - subroutine get_weights_exact(weights,xseg,yseg,nreconstruction) -! use cslam_analytic_mod, only: I_00, I_10, I_01, I_20, I_02, I_11 - implicit none - integer (kind=int_kind), intent(in) :: nreconstruction - real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights - real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg - ! - ! compute weights - ! - real (kind=real_kind) :: tmp,slope,b,integral,dx2,xc - integer (kind=int_kind) :: i -! weights(:) = -half*(xseg(1)*yseg(2)-xseg(2)*yseg(1)) !dummy for testing - - weights(1) = ((I_00(xseg(2),yseg(2))-I_00(xseg(1),yseg(1)))) - if (ABS(weights(1))>1.0) THEN - WRITE(*,*) "1 exact weights(jsegment)",weights(1),xseg,yseg - stop - end if - if (nreconstruction>1) then - weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1)))) - weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1)))) - endif - if (nreconstruction>3) then - weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1)))) - weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1)))) - weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1)))) - endif - - end subroutine get_weights_exact - - - - subroutine get_weights_gauss(weights,xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae) - implicit none - integer (kind=int_kind), intent(in) :: nreconstruction,ngauss - real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights - real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg - real (kind=real_kind) :: slope - ! - ! compute weights - ! - ! - ! for Gaussian quadrature - ! - real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae - - ! if line-segment parallel to x or y use exact formulaes else use qudrature - ! - real (kind=real_kind) :: tmp,b,integral,dx2,xc,x,y - integer (kind=int_kind) :: i - - - - -! if (fuzzy(abs(xseg(1) -xseg(2)),fuzzy_width)==0)then - if (xseg(1).EQ.xseg(2))then - weights = 0.0D0 - else if (abs(yseg(1) -yseg(2))1) then - weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1)))) - weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1)))) - endif - if (nreconstruction>3) then - weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1)))) - weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1)))) - weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1)))) - endif - else - - - slope = (yseg(2)-yseg(1))/(xseg(2)-xseg(1)) - b = yseg(1)-slope*xseg(1) - dx2 = 0.5D0*(xseg(2)-xseg(1)) - if (ldbgr) WRITE(*,*) "dx2 and slope in gauss weight",dx2,slope - xc = 0.5D0*(xseg(1)+xseg(2)) - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_00(x,y) - enddo - weights(1) = integral*dx2 - if (nreconstruction>1) then - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_10(x,y) - enddo - weights(2) = integral*dx2 - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_01(x,y) - enddo - weights(3) = integral*dx2 - endif - if (nreconstruction>3) then - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_20(x,y) - enddo - weights(4) = integral*dx2 - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_02(x,y) - enddo - weights(5) = integral*dx2 - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_11(x,y) - enddo - weights(6) = integral*dx2 - endif - end if - end subroutine get_weights_gauss - - real (kind=real_kind) function F_00(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_00 =y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) - end function F_00 - - real (kind=real_kind) function F_10(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_10 =x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) - end function F_10 - - real (kind=real_kind) function F_01(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_01 =-1.0D0/(SQRT(1.0D0+x*x+y*y)) - end function F_01 - - real (kind=real_kind) function F_20(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_20 =x*x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) - end function F_20 - - real (kind=real_kind) function F_02(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,alpha, tmp - - x = x_in - y = y_in - - alpha = ATAN(x) - tmp=y*COS(alpha) - F_02 =-y/SQRT(1.0D0+x*x+y*y)+log(tmp+sqrt(tmp*tmp+1)) - - ! - ! cos(alpha) = 1/sqrt(1+x*x) - ! - end function F_02 - - real (kind=real_kind) function F_11(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_11 =-x/(SQRT(1.0D0+x*x+y*y)) - end function F_11 - - subroutine which_eul_cell(x,j_eul,gno) - implicit none - integer (kind=int_kind) , intent(inout) :: j_eul - real (kind=real_kind), dimension(3) , intent(in) :: x - real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl -! real (kind=real_kind), intent(in) :: eps - - real (kind=real_kind) :: d1,d2,d3,d1p1 - logical :: lcontinue - integer :: iter - - - ! - ! this is not needed in transport code search - ! -! IF (x(1)gno(nc+2+nhe)) j_eul=nc+1+nhe -! RETURN - -! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added - - lcontinue = .TRUE. - iter = 0 - IF (ldbgr) WRITE(*,*) "from which_eul_cell",x(1),x(2),x(3) - DO WHILE (lcontinue) - iter = iter+1 - IF (x(1).GE.gno(j_eul).AND.x(1).LT.gno(j_eul+1)) THEN - lcontinue = .FALSE. - ! - ! special case when x(1) is on top of grid line - ! - IF (x(1).EQ.gno(j_eul)) THEN -! IF (ABS(x(1)-gno(j_eul))1000.OR.j_eul<-nhe.OR.j_eul>nc+2+nhe) THEN - WRITE(*,*) "search in which_eul_cell not converging!", iter,j_eul - WRITE(*,*) "input", x - WRITE(*,*) "gno", gno(nc),gno(nc+1),gno(nc+2),gno(nc+3) - STOP - END IF - END DO - END subroutine which_eul_cell - - - subroutine truncate_vertex(x,j_eul,gno) - implicit none - integer (kind=int_kind) , intent(inout) :: j_eul - real (kind=real_kind) , intent(inout) :: x - real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl -! real (kind=real_kind), intent(in) :: eps - - logical :: lcontinue - integer :: iter - real (kind=real_kind) :: xsgn,dist,dist_new,tmp - - ! - ! this is not needed in transport code search - ! -! IF (xgno(nc+2+nhe)) j_eul=nc+1+nhe -! -! RETURN - - - lcontinue = .TRUE. - iter = 0 - dist = bignum -! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added - xsgn = INT(SIGN(1.0_dbl_kind,x-gno(j_eul))) - DO WHILE (lcontinue) - iter = iter+1 - tmp = x-gno(j_eul) - dist_new = ABS(tmp) - IF (dist_new>dist) THEN - lcontinue = .FALSE. -! ELSE IF (ABS(tmp)<1.0E-11) THEN - ELSE IF (ABS(tmp)<1.0E-9) THEN -! ELSE IF (ABS(tmp)<1.0E-4) THEN - x = gno(j_eul) - lcontinue = .FALSE. - ELSE - j_eul = j_eul+xsgn - dist = dist_new - END IF - IF (iter>10000) THEN - WRITE(*,*) "truncate vertex not converging" - STOP - END IF - END DO - END subroutine truncate_vertex - - - - -!******************************************************************************** -! -! Gauss-Legendre quadrature -! -! Tabulated values -! -!******************************************************************************** -subroutine gauss_points(n,weights,points) - implicit none - real (kind=real_kind), dimension(n), intent(out) :: weights, points - integer (kind=int_kind) , intent(in ) :: n - - select case (n) -! CASE(1) -! abscissae(1) = 0.0D0 -! weights(1) = 2.0D0 - case(2) - points(1) = -sqrt(1.0D0/3.0D0) - points(2) = sqrt(1.0D0/3.0D0) - weights(1) = 1.0D0 - weights(2) = 1.0D0 - case(3) - points(1) = -0.774596669241483377035853079956D0 - points(2) = 0.0D0 - points(3) = 0.774596669241483377035853079956D0 - weights(1) = 0.555555555555555555555555555556D0 - weights(2) = 0.888888888888888888888888888889D0 - weights(3) = 0.555555555555555555555555555556D0 - case(4) - points(1) = -0.861136311594052575223946488893D0 - points(2) = -0.339981043584856264802665659103D0 - points(3) = 0.339981043584856264802665659103D0 - points(4) = 0.861136311594052575223946488893D0 - weights(1) = 0.347854845137453857373063949222D0 - weights(2) = 0.652145154862546142626936050778D0 - weights(3) = 0.652145154862546142626936050778D0 - weights(4) = 0.347854845137453857373063949222D0 - case(5) - points(1) = -(1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0)) - points(2) = -(1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0)) - points(3) = 0.0D0 - points(4) = (1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0)) - points(5) = (1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0)) - weights(1) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0 - weights(2) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0 - weights(3) = 128.0D0/225.0D0 - weights(4) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0 - weights(5) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0 - case default - write(*,*) 'n out of range in glwp of module gll. n=',n - write(*,*) '0 0.0D0) THEN - signum = 1.0D0 - ELSEIF (x < 0.0D0) THEN - signum = -1.0D0 - ELSE - signum = 0.0D0 - ENDIF - end function - -!------------------------------------------------------------------------------ -! FUNCTION SIGNUM_FUZZY -! -! Description: -! Gives the sign of the given real number, returning zero if x is within -! a small amount from zero. -!------------------------------------------------------------------------------ - function signum_fuzzy(x) - implicit none - - real (kind=real_kind) :: signum_fuzzy - real (kind=real_kind) :: x - - IF (x > fuzzy_width) THEN - signum_fuzzy = 1.0D0 - ELSEIF (x < fuzzy_width) THEN - signum_fuzzy = -1.0D0 - ELSE - signum_fuzzy = 0.0D0 - ENDIF - end function - - function fuzzy(x,epsilon) - implicit none - - integer (kind=int_kind) :: fuzzy - real (kind=real_kind), intent(in) :: epsilon - real (kind=real_kind) :: x - - IF (ABS(x)epsilon) THEN - fuzzy = 1 - ELSE !IF (x < fuzzy_width) THEN - fuzzy = -1 - ENDIF - end function - -! -! see, e.g., http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ -! -subroutine check_lines_cross(x1,x2,x3,x4,y1,y2,y3,y4,lcross) - implicit none - real (kind=real_kind), INTENT(IN) :: x1,x2,x3,x4,y1,y2,y3,y4 - LOGICAL, INTENT(OUT) :: lcross - ! - ! local workspace - ! - real (kind=real_kind) :: cp,tx,ty - - cp = (y4-y3)*(x2-x1)-(x4-x3)*(y2-y1) - IF (ABS(cp)-tiny.AND.tx<1.0D0+tiny.AND.& - ty>-tiny.AND.ty<1.0D0+tiny) THEN - lcross = .TRUE. - ELSE - lcross = .FALSE. -! WRITE(*,*) "not parallel but not crossing,",tx,ty - ENDIF - ENDIF -end subroutine check_lines_cross - - - REAL (KIND=dbl_kind) FUNCTION I_00(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y - - x = x_in/aa - y = y_in/aa -! x = x_in -! y = y_in - I_00 = ATAN(x*y/SQRT(one+x*x+y*y)) - END FUNCTION I_00 - - REAL (KIND=dbl_kind) FUNCTION I_10(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y,tmp - - x = x_in/aa - y = y_in/aa - tmp = ATAN(x) - I_10 = -ASINH(y*COS(tmp)) - ! - ! = -arcsinh(y/sqrt(1+x^2)) - ! - END FUNCTION I_10 - - REAL (KIND=dbl_kind) FUNCTION I_10_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - I_10_ab = -ASINH(COS(alpha) * TAN(beta)) - END FUNCTION I_10_AB - - REAL (KIND=dbl_kind) FUNCTION I_01(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y!,beta - - x = x_in/aa - y = y_in/aa -! beta = ATAN(y) -! I_01 = -ASINH(x*COS(beta)) - I_01 = -ASINH(x/SQRT(1+y*y)) - END FUNCTION I_01 - - REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - I_01_ab = -ASINH(COS(beta) * TAN(alpha)) - END FUNCTION I_01_AB - - REAL (KIND=dbl_kind) FUNCTION I_20(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta - - x = x_in/aa - y = y_in/aa -! alpha = aa*ATAN(x) -! beta = aa*ATAN(y) - - tmp = one+y*y - -! I_20 = y*ASINH(COS(beta)*x)+ACOS(SIN(alpha)*SIN(beta)) - I_20 = y*ASINH(x/SQRT(tmp))+ACOS(x*y/(SQRT((one+x*x)*tmp))) - END FUNCTION I_20 - - REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - - I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta)) - END FUNCTION I_20_AB - - REAL (KIND=dbl_kind) FUNCTION I_02(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta - - x = x_in/aa - y = y_in/aa -! alpha = aa*ATAN(x) -! beta = aa*ATAN(y) - - tmp=one+x*x - - I_02 = x*ASINH(y/SQRT(tmp))+ACOS(x*y/SQRT(tmp*(1+y*y))) - END FUNCTION I_02 - - REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - - I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta)) - END FUNCTION I_02_AB - - - REAL (KIND=dbl_kind) FUNCTION I_11(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y - - x = x_in/aa - y = y_in/aa - - I_11 = -SQRT(1+x*x+y*y) - END FUNCTION I_11 - - REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - - I_11_ab = -SQRT(one+TAN(alpha)**2+TAN(beta)**2) - END FUNCTION I_11_AB -!------------------------------------------------------------------------------ -! FUNCTION ASINH -! -! Description: -! Hyperbolic arcsin function -!------------------------------------------------------------------------------ - FUNCTION ASINH(x) - IMPLICIT NONE - - REAL (KIND=dbl_kind) :: ASINH - REAL (KIND=dbl_kind) :: x - - ASINH = LOG(x + SQRT(x * x + one)) - END FUNCTION - - - !******************************************************************************** - ! - ! Gauss-Legendre quadrature - ! - ! Tabulated values - ! - !******************************************************************************** - SUBROUTINE glwp(n,weights,abscissae) - IMPLICIT NONE - REAL (KIND=dbl_kind), DIMENSION(n), INTENT(OUT) :: weights, abscissae - INTEGER (KIND=int_kind) , INTENT(IN ) :: n - - SELECT CASE (n) - CASE(1) - abscissae(1) = 0.0 - weights(1) = 2.0 - CASE(2) - abscissae(1) = -SQRT(1.0/3.0) - abscissae(2) = SQRT(1.0/3.0) - weights(1) = 1.0 - weights(2) = 1.0 - CASE(3) - abscissae(1) = -0.774596669241483377035853079956_dbl_kind - abscissae(2) = 0.0 - abscissae(3) = 0.774596669241483377035853079956_dbl_kind - weights(1) = 0.555555555555555555555555555556_dbl_kind - weights(2) = 0.888888888888888888888888888889_dbl_kind - weights(3) = 0.555555555555555555555555555556_dbl_kind - CASE(4) - abscissae(1) = -0.861136311594052575223946488893_dbl_kind - abscissae(2) = -0.339981043584856264802665659103_dbl_kind - abscissae(3) = 0.339981043584856264802665659103_dbl_kind - abscissae(4) = 0.861136311594052575223946488893_dbl_kind - weights(1) = 0.347854845137453857373063949222_dbl_kind - weights(2) = 0.652145154862546142626936050778_dbl_kind - weights(3) = 0.652145154862546142626936050778_dbl_kind - weights(4) = 0.347854845137453857373063949222_dbl_kind - CASE(5) - abscissae(1) = -(1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0)) - abscissae(2) = -(1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0)) - abscissae(3) = 0.0 - abscissae(4) = (1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0)) - abscissae(5) = (1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0)) - weights(1) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - weights(2) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - weights(3) = 128.0_dbl_kind/225.0_dbl_kind - weights(4) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - weights(5) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - CASE DEFAULT - WRITE(*,*) 'n out of range in glwp of module gll. n=',n - WRITE(*,*) '0 shr_kind_r8 - implicit none -! - integer, parameter :: ntile = 33 ! number of tiles in USGS GTOPO30 dataset - integer, parameter :: im = 43200 ! total grids in x direction of 30-sec global dataset - integer, parameter :: jm = 21600 ! total grids in y direction of 30-sec global dataset - real(r8), parameter :: dx = 1.0/120.0 ! space interval for 30-sec data (in degree) - - character (len=7) :: nmtile(ntile) ! name of each tile - integer :: ncols,nrows ! number of columns and rows for 30-sec tile - integer :: nodata ! integer for ocean point - real(r8):: ulxmap ! longitude at the center of the upper-left corner cell in the 30-sec tile - real(r8):: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile - real(r8):: lon_start ! longitude at the center of grid (1,1) in the 30-sec netCDF global data - real(r8):: lat_start ! latitude at the center of grid (1,1) in the 30-sec netCDF global data - real(r8):: lonsw ! longitude at the center of southwest corner cell in the 30-sec tile - real(r8):: latsw ! latitude at the center of southwest corner cell in the 30-sec tile - integer :: i1,j1 ! the (i,j) point of the southwest corner of the 30-sec tile in the global grid - - integer*2, allocatable, dimension(:,:) :: terr ! global 30-sec terrain data - integer*1, allocatable, dimension(:,:) :: land_fraction ! global 30-sec land fraction - - integer :: alloc_error,dealloc_error - integer :: i,j,n ! index - integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile - integer*2, allocatable, dimension(:,:) :: terr_tile ! terrain data for 30-sec tile - integer*1, allocatable, dimension(:,:) :: land_fraction_tile -! - lat_start=-90.0 + 0.5 * dx - lon_start=0.5*dx - ! - ! Initialize each tile name - ! - nmtile(1) = 'W180N90' - nmtile(2) = 'W140N90' - nmtile(3) = 'W100N90' - nmtile(4) = 'W060N90' - nmtile(5) = 'W020N90' - nmtile(6) = 'E020N90' - nmtile(7) = 'E060N90' - nmtile(8) = 'E100N90' - nmtile(9) = 'E140N90' - - nmtile(10) = 'W180N40' - nmtile(11) = 'W140N40' - nmtile(12) = 'W100N40' - nmtile(13) = 'W060N40' - nmtile(14) = 'W020N40' - nmtile(15) = 'E020N40' - nmtile(16) = 'E060N40' - nmtile(17) = 'E100N40' - nmtile(18) = 'E140N40' - - nmtile(19) = 'W180S10' - nmtile(20) = 'W140S10' - nmtile(21) = 'W100S10' - nmtile(22) = 'W060S10' - nmtile(23) = 'W020S10' - nmtile(24) = 'E020S10' - nmtile(25) = 'E060S10' - nmtile(26) = 'E100S10' - nmtile(27) = 'E140S10' - - nmtile(28) = 'W180S60' - nmtile(29) = 'W120S60' - nmtile(30) = 'W060S60' - nmtile(31) = 'W000S60' - nmtile(32) = 'E060S60' - nmtile(33) = 'E120S60' - - - allocate ( land_fraction(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for land_fraction' - stop - end if - - allocate ( terr(im,jm),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr' - stop - end if - - do j = 1, jm - do i = 1, im - terr(i,j) = -999999.0 - land_fraction(i,j) = -99.0 - end do - end do - - do n = 1,ntile -! -! Read header for each tile -! - call rdheader(nmtile(n),nrows,ncols,nodata,ulxmap,ulymap) - -! -! Allocate space for array iterr -! - allocate ( iterr(ncols,nrows),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for iterr' - stop - end if -! -! Read terr data for each tile -! - call rdterr(nmtile(n),nrows,ncols,iterr) -! -! Allocate space for arrays terr_tile and psea10m -! - allocate ( terr_tile(ncols,nrows),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr_tile' - stop - end if - allocate ( land_fraction_tile(ncols,nrows),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for land_fraction_tile' - stop - end if -! -! Expand Caspian Sea for tiles 6 and 15 -! - if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,3600,5300) - if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,4088,5874) - if(nmtile(n).eq.'E020N40')call expand_sea(ncols,nrows,iterr,nodata,3600,1) - print *, "min and maxiterr: ", minval(iterr), maxval(iterr) -! -! area average of 30-sec tile to 30-sec tile -! - call avg(ncols,nrows,iterr,nodata,ulymap,dx,terr_tile,land_fraction_tile) - -! -! Print some info on the fields - print *, "min and max elevations: ", minval(terr_tile), maxval(terr_tile) - print *, "min and max land_fraction: ", minval(land_fraction_tile), maxval(land_fraction_tile) -! -! fit the 30-sec tile into global 30-sec dataset -! - - latsw= ulymap - (nrows-1) * dx - lonsw = ulxmap - if( lonsw < 0.0 ) lonsw=360.0+lonsw - i1 = nint( (lonsw - lon_start) / dx )+1 - if( i1 <= 0 ) i1 = i1 + im - if( i1 > im ) i1 = i1 - im - j1 = nint( (latsw- lat_start) / dx )+1 - -! print*,'ulymap,ulxmap,latsw10,lonsw = ',ulymap,ulxmap,latsw10,lonsw -! print*,'i1,j1 = ', i1,j1 - - call fitin(ncols,nrows,terr_tile,land_fraction_tile,i1,j1,im,jm,terr,land_fraction) -! -! Deallocate working space for arrays iterr, terr_tile and psea10m -! - deallocate ( iterr,terr_tile,land_fraction_tile,stat=dealloc_error ) - if( dealloc_error /= 0 ) then - print*,'Unexpected deallocation error for arrays iterr,terr_tile' - stop - end if - - end do - WRITE(*,*) 'done reading in USGS data' -! -! Print some info on the fields - print *, "min and max elevations: ", minval(terr), maxval(terr) - print *, "min and max land frac: ", minval(land_fraction), maxval(land_fraction) -! -! Write 30-sec terrain dataset, and land_fraction to NetCDF file -! -! call wrtncdf(im,jm,terr,land_fraction,dx) - call wrtncdf(im,jm,terr,land_fraction,dx,100) - end program convterr - - subroutine rdheader(nmtile,nrows,ncols,nodata,ulxmap,ulymap) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine read the header of USGA Global30 sec TOPO data set. -! - implicit none -! -! Dummy arguments -! - character (len=7), intent(in) :: nmtile ! name of the tile - integer, intent(out) :: nrows ! number of rows - integer, intent(out) :: ncols ! number of column - integer, intent(out) :: nodata ! integer for ocean data point - real(r8), intent(out) :: ulxmap - real(r8), intent(out) :: ulymap -! -! Local variables -! - character (len=11) :: flheader ! file name of the header - character (len=13) :: chars ! dummy character - - flheader=nmtile//'.HDR' - - print*,'flheader = ', flheader -! -! Open GTOPO30 Header File -! - open(unit=10,file=flheader,status='old',form='formatted') -! -! Read GTOPO30 Header file -! - read (10, *) - read (10, *) - read (10, *) chars,nrows - print*,chars,' = ',nrows - read (10, *) chars,ncols - print*,chars,' = ',ncols - read (10, *) - read (10, *) - read (10, *) - read (10, *) - read (10, *) - read (10, *) chars,nodata - print*,chars,' = ',nodata - read (10, *) chars,ulxmap - print*,chars,' = ',ulxmap - read (10, *) chars,ulymap - print*,chars,' = ',ulymap - close(10) - - end subroutine rdheader - - subroutine rdterr(nmtile,nrows,ncols,iterr) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine read the USGS Global 30-sec terrain data for each tile. -! - implicit none -! -! Dummy arguments -! - character (len=7), intent(in) :: nmtile ! name of the tile - integer, intent(in) :: nrows ! number of rows - integer, intent(in) :: ncols ! number of column - integer*2, dimension(ncols,nrows), intent(out) :: iterr ! terrain data -! -! Local variables -! - character (len=11) :: flterr ! file name for each terr dataset - integer :: io_error ! I/O status - integer :: i,j ! Index - integer :: length ! record length - - flterr=nmtile//'.DEM' - -! print*,'flterr = ', flterr -! print*,'nrows,ncols = ',nrows,ncols -! -! Open GTOPO30 Terrain dataset File -! - - length = 2 * ncols * nrows - io_error=0 - open(unit=11,file=flterr,access='direct',recl=length,iostat=io_error) - if( io_error /= 0 ) then - print*,'Open file error in subroutine rdterr' - print*,'iostat = ', io_error - stop - end if -! -! Read GTOPO30 Terrain data file -! - read (11,rec=1,iostat=io_error) ((iterr(i,j),i=1,ncols),j=1,nrows) -! - if( io_error /= 0 ) then - print*,'Data file error in subroutine rdterr' - print*,'iostat = ', io_error - stop - end if -! -! Print some info on the fields - print *, "min and max elevations: ", minval(iterr), maxval(iterr) -! -! Correct missing data in source files -! -! Missing data near dateline - - if( nmtile == 'W180S60' ) then - do j = 1, nrows - iterr(1,j) = iterr(2,j) - end do - else if (nmtile == 'E120S60') then - do j = 1, nrows - iterr(ncols-1,j) = iterr(ncols-2,j) - iterr(ncols,j) = iterr(ncols-2,j) - end do - end if -! -! Missing data at the southermost row near South pole -! - if( nmtile == 'E060S60' .or. nmtile == 'E120S60' .or. nmtile == 'W000S60' .or. & - nmtile == 'W060S60' .or. nmtile == 'W120S60' .or. nmtile == 'W180S60' ) then - do i=1,ncols - iterr(i,nrows) = iterr(i,nrows-1) - end do - end if -! -! print*,'iterr(1,1),iterr(ncols,nrows) = ', & -! iterr(1,1),iterr(ncols,nrows) - - close (11) - end subroutine rdterr - - subroutine avg(ncols,nrows,iterr,nodata,ulymap,dx,terr_tile,land_fraction_tile) - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none -! -! Dummy arguments -! - integer, intent(in) :: ncols ! number of column for 30-sec tile - integer, intent(in) :: nrows ! number of rows for 30-sec tile - integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile - integer, intent(in) :: nodata ! integer for ocean data point - real(r8),intent(in) :: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile - real(r8),intent(in) :: dx ! spacing interval for 30-sec data (in degree) - integer*2, dimension(ncols,nrows), intent(out) :: terr_tile ! terrain data for 30-sec tile - integer*1, dimension(ncols,nrows), intent(out) :: land_fraction_tile -! -! Local variables -! - real(r8) :: lats,latn ! latitudes (in rad) for ths south and north edges of each 30-sec cell - real(r8) :: wt ! area weighting of each 30-sec cell - real(r8) :: wt_tot ! total weighting of each 30-sec cell - real(r8) :: sumterr ! summation of terrain height of each 30-sec cell - real(r8) :: sumsea ! summation of sea coverage of each 30-sec cell - real(r8) :: pi ! pi=3.1415 - real(r8) :: latul ! latitude of the upper-left coner of 30-sec tile - integer :: n1,itmp,i1,i2,j1,j2 ! temporary working spaces - integer :: i,j,ii,jj ! index - logical, dimension(ncols,nrows) :: oflag - - pi = 4.0 * atan(1.0) -! - n1 = ncols / ncols - print*,'ncols,ncols,n1 = ',ncols,ncols,n1 - - itmp = nint( ulymap + 0.5 * dx ) - latul = itmp - print*,'ulymap,latul = ', ulymap,latul - oflag = .false. - - do j = 1, nrows - j1 = j - j2 = j - do i = 1, ncols - i1 = i - i2 = i - terr_tile(i,j) = 0 - land_fraction_tile(i,j) = 1 - if ( iterr(i,j) == nodata ) then - land_fraction_tile(i,j) = 0 - else - if ( iterr(i,j) .lt.nodata ) then - ! this can only happen in the expand_sea routine - land_fraction_tile(i,j) = 0 - iterr(i,j) = iterr(i,j) - nodata - nodata - endif - terr_tile(i,j) = iterr(i,j) - end if - end do - end do - - end subroutine avg - - subroutine expand_sea(ncols,nrows,iterr,nodata,startx,starty) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine reduces the resolution of the terrain data from 30-sec to 30-sec and -! compute the percentage of ocean cover (psea10m) -! - implicit none -! -! Dummy arguments -! - integer, intent(in) :: ncols ! number of column for 30-sec tile - integer, intent(in) :: nrows ! number of rows for 30-sec tile - integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile - integer, intent(in) :: nodata ! integer for ocean data point - integer, intent(in) :: startx, starty ! where to begin the sea -! -! Local variables -! - real(r8):: maxh - integer :: i,j,per,ii,jj ! index - logical, dimension(0:ncols+1,0:nrows+1) :: flag ! terrain data for 30-sec tile - logical :: found - - flag = .false. - - maxh = iterr(startx,starty) - - iterr(startx,starty) = iterr(startx,starty) + nodata + nodata - flag(startx-1:startx+1,starty-1:starty+1) = .true. - - per = 0 - print *, 'expanding sea at ',maxh,' m ' - -2112 per = per + 1 - found = .false. - do j = starty - per, starty + per, per*2 - do i = startx - per, startx + per - if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then - if( iterr(i,j).eq.maxh .and. flag(i,j) ) then - iterr(i,j) = iterr(i,j) + nodata + nodata - flag(i-1:i+1,j-1:j+1) = .true. - found = .true. - endif - endif - end do - end do - - do i = startx - per, startx + per, per*2 - do j = starty - per + 1, starty + per - 1 - if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then - if( iterr(i,j).eq.maxh .and. flag(i,j) ) then - iterr(i,j) = iterr(i,j) + nodata + nodata - flag(i-1:i+1,j-1:j+1) = .true. - found = .true. - endif - endif - end do - end do - if (found)goto 2112 - print *, 'done with expand_sea' - return - - end subroutine expand_sea - - subroutine fitin(ncols,nrows,terr_tile,land_fraction_tile,i1,j1,im,jm,terr,land_fraction) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine put 30-sec tile into the global dataset -! - implicit none -! -! Dummy arguments -! - integer, intent(in) :: ncols ! number of columns for 30-sec tile - integer, intent(in) :: nrows ! number of rows for 30-sec tile - integer*2, dimension(ncols,nrows), intent(in) :: terr_tile ! terrain data for 30-sec tile - integer*1, dimension(ncols,nrows), intent(in) :: land_fraction_tile - integer, intent(in) :: i1,j1 ! the (i,j) point of the southwest corner of the 30-sec tile - ! in the global grid - integer, intent(in) :: im,jm ! the dimensions of the 30-sec global dataset - integer*2,dimension(im,jm), intent(out) :: terr ! global 30-sec terrain data - integer*1,dimension(im,jm), intent(out) :: land_fraction ! global 30-sec land fraction -! -! Local variables -! - integer :: i,j,ii,jj ! index - - do j = 1, nrows - jj = j1 + (nrows - j) - do i = 1, ncols - ii = i1 + (i-1) - - if( i == 1 .and. j == 1 ) & - print*,'i,j,ii,jj = ',i,j,ii,jj - if( i == ncols .and. j == nrows ) & - print*,'i,j,ii,jj = ',i,j,ii,jj - - if( ii > im ) ii = ii - im - terr(ii,jj) = terr_tile(i,j) - land_fraction(ii,jj) = land_fraction_tile(i,j) - end do - end do - end subroutine fitin - - subroutine wrtncdf(im,jm,terr,land_fraction,dx) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine save 30-sec terrain data, land fraction to NetCDF file -! - implicit none - -# include - -! -! Dummy arguments -! - integer, intent(in) :: im,jm ! the dimensions of the 30-sec global dataset - integer*2,dimension(im,jm), intent(in) :: terr ! global 30-sec terrain data - integer*1,dimension(im,jm), intent(in) :: land_fraction !global 30-sec land fraction - real(r8), intent(in) :: dx -! -! Local variables -! - real(r8),dimension(im) :: lonar ! longitude array - real(r8),dimension(im) :: latar ! latitude array - character (len=32) :: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: htopoid - integer :: landfid - integer, dimension(2) :: htopodim,landfdim - integer :: status ! return value for error control of netcdf routin - integer :: i,j - character (len=8) :: datestring - - integer*2,dimension(im,jm) :: h ! global 30-sec terrain data - integer*1,dimension(im,jm) :: lnd - - -! -! Fill lat and lon arrays -! - do i = 1,im - lonar(i)= dx * (i-0.5) - enddo - do j = 1,jm - latar(j)= -90.0 + dx * (j-0.5) - enddo - - do j=1,jm - do i=1,im - h(i,j) = terr(i,j) - lnd(i,j) = land_fraction(i,j) - end do - end do - - fout='usgs-rawdata.nc' -! -! Create NetCDF file for output -! - print *,"Create NetCDF file for output" - status = nf_create (fout, NF_64BIT_OFFSET , foutid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Create dimensions for output -! - print *,"Create dimensions for output" - status = nf_def_dim (foutid, 'lon', im, lonid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'lat', jm, latid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Create variable for output -! - print *,"Create variable for output" - htopodim(1)=lonid - htopodim(2)=latid - status = nf_def_var (foutid,'htopo', NF_INT, 2, htopodim, htopoid) - if (status .ne. NF_NOERR) call handle_err(status) -! - landfdim(1)=lonid - landfdim(2)=latid - status = nf_def_var (foutid,'landfract', NF_INT, 2, landfdim, landfid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! Create attributes for output variables -! - status = nf_put_att_text (foutid,htopoid,'long_name', 41, '30-sec elevation from USGS 30-sec dataset') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,htopoid,'units', 5, 'meter') - if (status .ne. NF_NOERR) call handle_err(status) -! - status = nf_put_att_text (foutid,landfid,'long_name', 23, '30-second land fraction') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,landfid,'units', 14, 'fraction (0-1)') - if (status .ne. NF_NOERR) call handle_err(status) -! - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! End define mode for output file -! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Write variable for output -! - print*,"writing terrain data" - status = nf_put_var_int2 (foutid, htopoid, h) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing terrain data" -! - status = nf_put_var_int1 (foutid, landfid, lnd) - if (status .ne. NF_NOERR) call handle_err(status) -! - print*,"writing lat data" - status = nf_put_var_double (foutid, latvid, latar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lat data" - - print*,"writing lon data" - status = nf_put_var_double (foutid, lonvid, lonar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lon data" -! -! Close output file -! - print *,"close file" - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - - end subroutine wrtncdf - - - ! - ! same as wrtncdf but the output is coarsened - ! - subroutine wrtncdf_coarse(im,jm,terr,land_fraction,dx,ic) - use shr_kind_mod, only: r8 => shr_kind_r8 -! -! This subroutine save 30-sec terrain data, land fraction to NetCDF file -! - implicit none - -# include - -! -! Dummy arguments -! - integer, intent(in) :: im,jm ! the dimensions of the 30-sec global dataset - integer, intent(in) :: ic ! coarsening factor - integer*2,dimension(im,jm), intent(in) :: terr ! global 30-sec terrain data - integer*1,dimension(im,jm), intent(in) :: land_fraction !global 30-sec land fraction - real(r8), intent(in) :: dx -! -! Local variables -! - real(r8),dimension(im/ic) :: lonar ! longitude array - real(r8),dimension(im/ic) :: latar ! latitude array - character (len=32) :: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: htopoid - integer :: landfid - integer, dimension(2) :: htopodim,landfdim - integer :: status ! return value for error control of netcdf routin - integer :: i,j - character (len=8) :: datestring - - integer*2,dimension(im/ic,jm/ic) :: h ! global 30-sec terrain data - integer*1,dimension(im/ic,jm/ic) :: lnd - - -! -! Fill lat and lon arrays -! - do i = 1,im/ic - lonar(i)= real(ic)*dx * (i-0.5) - enddo - do j = 1,jm/ic - latar(j)= -90.0 + real(ic)*dx * (j-0.5) - enddo - - do j=1,jm/ic - do i=1,im/ic - h(i,j) = terr(i*ic,j*ic) - lnd(i,j) = land_fraction(i*ic,j*ic) - end do - end do - - fout='usgs-lowres.nc' -! -! Create NetCDF file for output -! - print *,"Create NetCDF file for output" - status = nf_create (fout, NF_64BIT_OFFSET , foutid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Create dimensions for output -! - print *,"Create dimensions for output" - status = nf_def_dim (foutid, 'lon', im/ic, lonid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'lat', jm/ic, latid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Create variable for output -! - print *,"Create variable for output" - htopodim(1)=lonid - htopodim(2)=latid - status = nf_def_var (foutid,'htopo', NF_INT, 2, htopodim, htopoid) - if (status .ne. NF_NOERR) call handle_err(status) -! - landfdim(1)=lonid - landfdim(2)=latid - status = nf_def_var (foutid,'landfract', NF_INT, 2, landfdim, landfid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! Create attributes for output variables -! - status = nf_put_att_text (foutid,htopoid,'long_name', 41, '30-sec elevation from USGS 30-sec dataset') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,htopoid,'units', 5, 'meter') - if (status .ne. NF_NOERR) call handle_err(status) -! - status = nf_put_att_text (foutid,landfid,'long_name', 23, '30-second land fraction') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,landfid,'units', 14, 'fraction (0-1)') - if (status .ne. NF_NOERR) call handle_err(status) -! - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - -! -! End define mode for output file -! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -! -! Write variable for output -! - print*,"writing terrain data" - status = nf_put_var_int2 (foutid, htopoid, h) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing terrain data" -! - status = nf_put_var_int1 (foutid, landfid, lnd) - if (status .ne. NF_NOERR) call handle_err(status) -! - print*,"writing lat data" - status = nf_put_var_double (foutid, latvid, latar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lat data" - - print*,"writing lon data" - status = nf_put_var_double (foutid, lonvid, lonar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lon data" -! -! Close output file -! - print *,"close file" - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - - end subroutine wrtncdf_coarse -!************************************************************************ -!!handle_err -!************************************************************************ -! -!!ROUTINE: handle_err -!!DESCRIPTION: error handler -!-------------------------------------------------------------------------- - - subroutine handle_err(status) - - implicit none - -# include - - integer status - - if (status .ne. nf_noerr) then - print *, nf_strerror(status) - stop 'Stopped' - endif - - end subroutine handle_err - - - diff --git a/tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90 b/tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90 deleted file mode 100644 index fc1ed8e94a..0000000000 --- a/tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90 +++ /dev/null @@ -1,20 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - -END MODULE shr_kind_mod From f18cf2318c3c681d07b538d8f2a67da6930e35c1 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 18 Apr 2024 10:46:31 -0400 Subject: [PATCH 11/17] update ChangeLog --- doc/ChangeLog | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a7dcbc3594..13f56b2675 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -3,8 +3,8 @@ Tag name: Originator(s): eaton Date: -One-line Summary: Add vertical limit to COSP interface. -Github PR URL: +One-line Summary: Limit vertical domain used by COSP. +Github PR URL: https://github.com/ESCOMP/CAM/pull/1010 Purpose of changes (include the issue number and title text for each relevant GitHub issue): @@ -83,7 +83,7 @@ CAM tag used for the baseline comparison tests if different than previous tag: Summarize any changes to answers: BFB. Some COSP diagnostic fields have -answer changes due to a bug fix in data sent to COSP. +answer changes due to a bug fix in the data sent to COSP. =============================================================== =============================================================== From 37961cf91b76e4797284baea827e4e806907a21f Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 7 May 2024 19:03:55 -0400 Subject: [PATCH 12/17] add allocate stat checks; add some comments --- src/physics/cam/cospsimulator_intr.F90 | 258 +++++++++++++++---------- 1 file changed, 159 insertions(+), 99 deletions(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 0f7f1ff649..c1086a213b 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -15,7 +15,7 @@ module cospsimulator_intr use ppgrid, only: pcols, pver, pverp, begchunk, endchunk use ref_pres, only: ktop => trop_cloud_top_lev use perf_mod, only: t_startf, t_stopf - use cam_abortutils, only: endrun + use cam_abortutils, only: endrun, handle_allocate_error use phys_control, only: cam_physpkg_is use cam_logfile, only: iulog #ifdef USE_COSP @@ -522,7 +522,8 @@ subroutine cospsimulator_intr_init() use cam_history, only: addfld, add_default, horiz_only use physics_buffer, only: pbuf_get_index - integer :: i, ierr + integer :: i, ierr, istat + character(len=*), parameter :: sub = 'cospsimulator_intr_init' !--------------------------------------------------------------------------- ! The COSP init method was run from cospsimulator_intr_register in order to add @@ -648,7 +649,8 @@ subroutine cospsimulator_intr_init() end if ! RADAR SIMULATOR OUTPUTS - allocate(sd_cs(begchunk:endchunk), rcfg_cs(begchunk:endchunk)) + allocate(sd_cs(begchunk:endchunk), rcfg_cs(begchunk:endchunk), stat=istat) + call handle_allocate_error(istat, sub, 'sd_cs,rcfg_cs') if (lradar_sim) then do i = begchunk, endchunk @@ -879,9 +881,10 @@ subroutine cospsimulator_intr_init() lsflxprc_idx = pbuf_get_index('LS_FLXPRC') lsflxsnw_idx = pbuf_get_index('LS_FLXSNW') - allocate(first_run_cosp(begchunk:endchunk)) + allocate(first_run_cosp(begchunk:endchunk), run_cosp(1:pcols,begchunk:endchunk), & + stat=istat) + call handle_allocate_error(istat, sub, '*run_cosp') first_run_cosp(begchunk:endchunk)=.true. - allocate(run_cosp(1:pcols,begchunk:endchunk)) run_cosp(1:pcols,begchunk:endchunk)=.false. #endif @@ -900,6 +903,9 @@ subroutine setcosp2values() logical :: ldouble=.false. logical :: lsingle=.true. ! Default is to use single moment integer :: k + integer :: istat + character(len=*), parameter :: sub = 'setcosp2values' + !-------------------------------------------------------------------------------------- prsmid_cosp = pres_binCenters prslim_cosp = pres_binEdges @@ -965,7 +971,8 @@ subroutine setcosp2values() scol_cosp(nscol_cosp), & htdbze_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), & htsr_cosp(nht_cosp*nsr_cosp), & - htmlscol_cosp(nlay*nscol_cosp) ) + htmlscol_cosp(nlay*nscol_cosp), stat=istat) + call handle_allocate_error(istat, sub, 'htmlmid_cosp,..,htmlscol_cosp') ! DJS2017: Just pull from cosp_config if (use_vgrid) then @@ -1304,6 +1311,10 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & character(len=256),dimension(100) :: cosp_status integer :: nerror + integer :: istat + character(len=*), parameter :: sub = 'cospsimulator_intr_run' + !-------------------------------------------------------------------------------------- + call t_startf("init_and_stuff") ! ###################################################################################### ! Initialization @@ -1524,6 +1535,8 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! CALCULATE COSP INPUT VARIABLES FROM CAM VARIABLES, done for all columns within chunk !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! These arrays are dimensioned to only include active columns (ncol), and the number + ! of layers (nlay) and layer interfaces (nlayp) operated on by COSP. allocate( & zmid(ncol,nlay), & zint(ncol,nlayp), & @@ -1546,8 +1559,8 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & dtau_s_snow(ncol,nlay), & dem_s(ncol,nlay), & dem_c(ncol,nlay), & - dem_s_snow(ncol,nlay) & - ) + dem_s_snow(ncol,nlay), stat=istat) + call handle_allocate_error(istat, sub, 'zmid,..,dem_s_snow') ! add surface height (surface geopotential/gravity) to convert CAM heights based on ! geopotential above surface into height above sea level @@ -1591,6 +1604,24 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & rain_ls_interp(i,:) = rain_ls_interp(i,:) - snow_ls_interp(i,:) end do + !! Make sure interpolated values are not less than 0 + do k = 1, nlay + do i = 1, ncol + if (rain_ls_interp(i,k) < 0._r8) then + rain_ls_interp(i,k) = 0._r8 + end if + if (snow_ls_interp(i,k) < 0._r8) then + snow_ls_interp(i,k) = 0._r8 + end if + if (rain_cv_interp(i,k) < 0._r8) then + rain_cv_interp(i,k) = 0._r8 + end if + if (snow_cv_interp(i,k) < 0._r8) then + snow_cv_interp(i,k) = 0._r8 + end if + end do + end do + grpl_ls_interp = 0._r8 !! CAM5 cloud mixing ratio calculations @@ -1628,24 +1659,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & reff_cosp(:,:,I_CVSNOW) = ls_reffsnow(:ncol,ktop:pver)*1.e-6_r8 !! same as stratiform per Andrew reff_cosp(:,:,I_LSGRPL) = 0._r8 !! using radar default reff - !! Make sure interpolated values are not less than 0 - do k = 1, nlay - do i = 1, ncol - if (rain_ls_interp(i,k) < 0._r8) then - rain_ls_interp(i,k) = 0._r8 - end if - if (snow_ls_interp(i,k) < 0._r8) then - snow_ls_interp(i,k) = 0._r8 - end if - if (rain_cv_interp(i,k) < 0._r8) then - rain_cv_interp(i,k) = 0._r8 - end if - if (snow_cv_interp(i,k) < 0._r8) then - snow_cv_interp(i,k) = 0._r8 - end if - end do - end do - ! assign optical depths and emissivities ! CAM4 assumes same radiative properties for stratiform and convective clouds, ! (see ISCCP_CLOUD_TYPES subroutine call in cloudsimulator.F90) @@ -1716,6 +1729,10 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & call t_stopf("construct_cospIN") call t_startf("subsample_and_optics") + ! The arrays passed here contain only active columns and the limited vertical + ! domain operated on by COSP. Unsubscripted array arguments have alread been + ! allocated to the correct size. Arrays the size of a CAM chunk (pcol,pver) + ! need to pass the correct section (:ncol,ktop:pver). call subsample_and_optics( & ncol, nlay, nscol_cosp, nhydro, overlap, & use_precipitation_fluxes, lidar_ice_type,sd_cs(lchnk), & @@ -2391,7 +2408,7 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, type(cosp_column_inputs),intent(inout) :: cospstateIN ! Local variables - integer :: i,j,k + integer :: i, j, k, istat real(wp),dimension(nPoints,nLevels) :: column_frac_out,column_prec_out, & fl_lsrain,fl_lssnow,fl_lsgrpl,fl_ccrain, & fl_ccsnow @@ -2409,6 +2426,9 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, MODIS_opticalThicknessIce, & fracPrecipIce, fracPrecipIce_statGrid real(wp),dimension(:,:,:,:),allocatable :: mr_hydro,Reff,Np + + character(len=*), parameter :: sub = 'subsample_and_optics' + !-------------------------------------------------------------------------------------- call t_startf("scops") if (Ncolumns .gt. 1) then @@ -2416,7 +2436,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, ! Generate subcolumns for clouds (SCOPS) and precipitation type (PREC_SCOPS) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! RNG used for subcolumn generation - allocate(rngs(nPoints),seed(nPoints)) + allocate(rngs(nPoints), seed(nPoints), stat=istat) + call handle_allocate_error(istat, sub, 'rngs, seed') seed = int(sfcP) if (Npoints .gt. 1) seed=(sfcP-int(sfcP))*1000000 call init_rng(rngs, seed) @@ -2427,7 +2448,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, ! Sum up precipitation rates. If not using preciitation fluxes, mixing ratios are ! stored in _rate variables. - allocate(ls_p_rate(nPoints,nLevels),cv_p_rate(nPoints,Nlevels)) + allocate(ls_p_rate(nPoints,nLevels), cv_p_rate(nPoints,Nlevels), stat=istat) + call handle_allocate_error(istat, sub, 'ls_p_rate, cv_p_rate') if(use_precipitation_fluxes) then ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN @@ -2437,16 +2459,17 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, endif ! Call PREC_SCOPS - allocate(frac_prec(nPoints,nColumns,nLevels)) + allocate(frac_prec(nPoints,nColumns,nLevels), stat=istat) + call handle_allocate_error(istat, sub, 'frac_prec') call prec_scops(nPoints,nLevels,nColumns,ls_p_rate,cv_p_rate,cospIN%frac_out,frac_prec) deallocate(ls_p_rate,cv_p_rate) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! Compute precipitation fraction in each gridbox !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! Allocate - allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels), & - frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels)) + allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels), & + frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels), stat=istat) + call handle_allocate_error(istat, sub, 'frac_ls,..,prec_cv') ! Initialize frac_ls(1:nPoints,1:nLevels) = 0._wp @@ -2484,9 +2507,10 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, ! Compute mixing ratios, effective radii and precipitation fluxes for clouds ! and precipitation !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro), & - Reff(nPoints,nColumns,nLevels,nHydro), & - Np(nPoints,nColumns,nLevels,nHydro)) + allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro), & + Reff(nPoints,nColumns,nLevels,nHydro), & + Np(nPoints,nColumns,nLevels,nHydro), stat=istat) + call handle_allocate_error(istat, sub, 'mr_hydro,Reff,Np') ! Initialize mr_hydro(:,:,:,:) = 0._wp @@ -2611,7 +2635,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, else cospIN%frac_out(:,:,:) = 1 allocate(mr_hydro(nPoints, 1,nLevels,nHydro),Reff(nPoints,1,nLevels,nHydro), & - Np(nPoints,1,nLevels,nHydro)) + Np(nPoints,1,nLevels,nHydro), stat=istat) + call handle_allocate_error(istat, sub, 'mr_hydro,Reff,Np') mr_hydro(:,1,:,I_LSCLIQ) = mr_lsliq mr_hydro(:,1,:,I_LSCICE) = mr_lsice mr_hydro(:,1,:,I_CVCLIQ) = mr_ccliq @@ -2626,7 +2651,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, call t_startf("cloudsat_optics") if (lradar_sim) then ! Compute gaseous absorption (assume identical for each subcolun) - allocate(g_vol(nPoints,nLevels)) + allocate(g_vol(nPoints,nLevels), stat=istat) + call handle_allocate_error(istat, sub, 'g_vol') g_vol(:,:)=0._wp do i = 1, nPoints do j = 1, nLevels @@ -2640,7 +2666,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, end do ! Loop over all subcolumns - allocate(fracPrecipIce(nPoints,nColumns,nLevels)) + allocate(fracPrecipIce(nPoints,nColumns,nLevels), stat=istat) + call handle_allocate_error(istat, sub, 'fracPrecipIce') fracPrecipIce(:,:,:) = 0._wp do k=1,nColumns call quickbeam_optics(sd, cospIN%rcfg_cloudsat, nPoints, nLevels, R_UNDEF, & @@ -2663,7 +2690,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, enddo ! Regrid frozen fraction to Cloudsat/Calipso statistical grid - allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid)) + allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid), stat=istat) + call handle_allocate_error(istat, sub, 'fracPrecipIce_statGrid') fracPrecipIce_statGrid(:,:,:) = 0._wp call cosp_change_vertical_grid(Npoints, Ncolumns, Nlevels, cospstateIN%hgt_matrix(:,Nlevels:1:-1), & cospstateIN%hgt_matrix_half(:,Nlevels:1:-1), fracPrecipIce(:,:,Nlevels:1:-1), Nlvgrid, & @@ -2760,7 +2788,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, MODIS_snowSize(nPoints,nColumns,nLevels), & MODIS_opticalThicknessLiq(nPoints,nColumns,nLevels), & MODIS_opticalThicknessIce(nPoints,nColumns,nLevels), & - MODIS_opticalThicknessSnow(nPoints,nColumns,nLevels)) + MODIS_opticalThicknessSnow(nPoints,nColumns,nLevels), stat=istat) + call handle_allocate_error(istat, sub, 'MODIS_*') ! Cloud water call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out, & @@ -2816,6 +2845,11 @@ subroutine construct_cospIN(npoints,ncolumns,nlevels,y) nlevels ! Number of vertical levels ! Outputs type(cosp_optical_inputs),intent(out) :: y + + ! local + integer :: istat + character(len=*), parameter :: sub = 'construct_cospIN' + !-------------------------------------------------------------------------------------- ! Dimensions y%Npoints = Npoints @@ -2843,7 +2877,9 @@ subroutine construct_cospIN(npoints,ncolumns,nlevels,y) y%tau_mol_calipso( npoints, nlevels),& y%tautot_S_ice( npoints, ncolumns ),& y%tautot_S_liq( npoints, ncolumns) ,& - y%fracPrecipIce(npoints, ncolumns)) + y%fracPrecipIce(npoints, ncolumns), stat=istat) + call handle_allocate_error(istat, sub, 'tau_067,..,fracPrecipIce') + end subroutine construct_cospIN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -2858,6 +2894,11 @@ subroutine construct_cospstateIN(npoints,nlevels,nchan,y) ! Outputs type(cosp_column_inputs),intent(out) :: y + ! local + integer :: istat + character(len=*), parameter :: sub = 'construct_cospstateIN' + !-------------------------------------------------------------------------------------- + allocate( & y%sunlit(npoints), & y%at(npoints,nlevels), & @@ -2880,7 +2921,8 @@ subroutine construct_cospstateIN(npoints,nlevels,nchan,y) y%cloudIce(nPoints,nLevels), & y%cloudLiq(nPoints,nLevels), & y%fl_rain(nPoints,nLevels), & - y%fl_snow(nPoints,nLevels) ) + y%fl_snow(nPoints,nLevels), stat=istat) + call handle_allocate_error(istat, sub, 'sunlit,..,fl_snow') end subroutine construct_cospstateIN ! ###################################################################################### @@ -2899,85 +2941,103 @@ subroutine construct_cosp_outputs(Npoints,Ncolumns,Nlevels,Nlvgrid,x) ! Outputs type(cosp_outputs),intent(out) :: & x ! COSP output structure + + ! local + integer :: istat + character(len=*), parameter :: sub = 'construct_cosp_outputs' + !-------------------------------------------------------------------------------------- ! ISCCP simulator outputs if (lisccp_sim) then - allocate(x%isccp_boxtau(Npoints,Ncolumns)) - allocate(x%isccp_boxptop(Npoints,Ncolumns)) - allocate(x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins)) - allocate(x%isccp_totalcldarea(Npoints)) - allocate(x%isccp_meanptop(Npoints)) - allocate(x%isccp_meantaucld(Npoints)) - allocate(x%isccp_meantb(Npoints)) - allocate(x%isccp_meantbclr(Npoints)) - allocate(x%isccp_meanalbedocld(Npoints)) + allocate( & + x%isccp_boxtau(Npoints,Ncolumns), & + x%isccp_boxptop(Npoints,Ncolumns), & + x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins), & + x%isccp_totalcldarea(Npoints), & + x%isccp_meanptop(Npoints), & + x%isccp_meantaucld(Npoints), & + x%isccp_meantb(Npoints), & + x%isccp_meantbclr(Npoints), & + x%isccp_meanalbedocld(Npoints), stat=istat) + call handle_allocate_error(istat, sub, 'isccp_*') endif ! MISR simulator if (lmisr_sim) then - allocate(x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins)) - ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so - ! they are still computed. Should probably have a logical to control these - ! outputs. - allocate(x%misr_dist_model_layertops(Npoints,numMISRHgtBins)) - allocate(x%misr_meanztop(Npoints)) - allocate(x%misr_cldarea(Npoints)) + allocate( & + x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins), & + ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so + ! they are still computed. Should probably have a logical to control these + ! outputs. + x%misr_dist_model_layertops(Npoints,numMISRHgtBins), & + x%misr_meanztop(Npoints), & + x%misr_cldarea(Npoints), stat=istat) + call handle_allocate_error(istat, sub, 'misr_*') endif ! MODIS simulator if (lmodis_sim) then - allocate(x%modis_Cloud_Fraction_Total_Mean(Npoints)) - allocate(x%modis_Cloud_Fraction_Water_Mean(Npoints)) - allocate(x%modis_Cloud_Fraction_Ice_Mean(Npoints)) - allocate(x%modis_Cloud_Fraction_High_Mean(Npoints)) - allocate(x%modis_Cloud_Fraction_Mid_Mean(Npoints)) - allocate(x%modis_Cloud_Fraction_Low_Mean(Npoints)) - allocate(x%modis_Optical_Thickness_Total_Mean(Npoints)) - allocate(x%modis_Optical_Thickness_Water_Mean(Npoints)) - allocate(x%modis_Optical_Thickness_Ice_Mean(Npoints)) - allocate(x%modis_Optical_Thickness_Total_LogMean(Npoints)) - allocate(x%modis_Optical_Thickness_Water_LogMean(Npoints)) - allocate(x%modis_Optical_Thickness_Ice_LogMean(Npoints)) - allocate(x%modis_Cloud_Particle_Size_Water_Mean(Npoints)) - allocate(x%modis_Cloud_Particle_Size_Ice_Mean(Npoints)) - allocate(x%modis_Cloud_Top_Pressure_Total_Mean(Npoints)) - allocate(x%modis_Liquid_Water_Path_Mean(Npoints)) - allocate(x%modis_Ice_Water_Path_Mean(Npoints)) - allocate(x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins)) - allocate(x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins)) - allocate(x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins)) + allocate( & + x%modis_Cloud_Fraction_Total_Mean(Npoints), & + x%modis_Cloud_Fraction_Water_Mean(Npoints), & + x%modis_Cloud_Fraction_Ice_Mean(Npoints), & + x%modis_Cloud_Fraction_High_Mean(Npoints), & + x%modis_Cloud_Fraction_Mid_Mean(Npoints), & + x%modis_Cloud_Fraction_Low_Mean(Npoints), & + x%modis_Optical_Thickness_Total_Mean(Npoints), & + x%modis_Optical_Thickness_Water_Mean(Npoints), & + x%modis_Optical_Thickness_Ice_Mean(Npoints), & + x%modis_Optical_Thickness_Total_LogMean(Npoints), & + x%modis_Optical_Thickness_Water_LogMean(Npoints), & + x%modis_Optical_Thickness_Ice_LogMean(Npoints), & + x%modis_Cloud_Particle_Size_Water_Mean(Npoints), & + x%modis_Cloud_Particle_Size_Ice_Mean(Npoints), & + x%modis_Cloud_Top_Pressure_Total_Mean(Npoints), & + x%modis_Liquid_Water_Path_Mean(Npoints), & + x%modis_Ice_Water_Path_Mean(Npoints), & + x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins), & + x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins), & + x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins), & + stat=istat) + call handle_allocate_error(istat, sub, 'modis_*') endif ! CALIPSO simulator if (llidar_sim) then - allocate(x%calipso_beta_mol(Npoints,Nlevels)) - allocate(x%calipso_beta_tot(Npoints,Ncolumns,Nlevels)) - allocate(x%calipso_srbval(SR_BINS+1)) - allocate(x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid)) - allocate(x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels)) - allocate(x%calipso_lidarcld(Npoints,Nlvgrid)) - allocate(x%calipso_cldlayer(Npoints,LIDAR_NCAT)) - allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6)) - allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5)) - allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6)) - allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels)) - allocate(x%calipso_temp_tot(Npoints,Nlevels)) + allocate( & + x%calipso_beta_mol(Npoints,Nlevels), & + x%calipso_beta_tot(Npoints,Ncolumns,Nlevels), & + x%calipso_srbval(SR_BINS+1), & + x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid), & + x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels), & + x%calipso_lidarcld(Npoints,Nlvgrid), & + x%calipso_cldlayer(Npoints,LIDAR_NCAT), & + x%calipso_lidarcldphase(Npoints,Nlvgrid,6), & + x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5), & + x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6), & + x%calipso_tau_tot(Npoints,Ncolumns,Nlevels), & + x%calipso_temp_tot(Npoints,Nlevels), stat=istat) + call handle_allocate_error(istat, sub, 'calipso_*') endif ! PARASOL if (lparasol_sim) then - allocate(x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL)) - allocate(x%parasolGrid_refl(Npoints,PARASOL_NREFL)) + allocate( & + x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL), & + x%parasolGrid_refl(Npoints,PARASOL_NREFL), stat=istat) + call handle_allocate_error(istat, sub, 'parasol*') endif ! Cloudsat simulator if (lradar_sim) then - allocate(x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels)) - allocate(x%cloudsat_cfad_ze(Npoints,CLOUDSAT_DBZE_BINS,Nlvgrid)) - allocate(x%lidar_only_freq_cloud(Npoints,Nlvgrid)) - allocate(x%radar_lidar_tcc(Npoints)) - allocate(x%cloudsat_precip_cover(Npoints,nCloudsatPrecipClass)) - allocate(x%cloudsat_pia(Npoints)) + allocate( & + x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels), & + x%cloudsat_cfad_ze(Npoints,CLOUDSAT_DBZE_BINS,Nlvgrid), & + x%lidar_only_freq_cloud(Npoints,Nlvgrid), & + x%radar_lidar_tcc(Npoints), & + x%cloudsat_precip_cover(Npoints,nCloudsatPrecipClass), & + x%cloudsat_pia(Npoints), stat=istat) + call handle_allocate_error(istat, sub, 'cloudsat*') endif end subroutine construct_cosp_outputs From 5550915f3f07e711a8d7bcc49ed21a82511bfeca Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 8 May 2024 14:26:47 -0400 Subject: [PATCH 13/17] update ChangeLog --- doc/ChangeLog | 175 +++++++++++++++++++++++++------------------------- 1 file changed, 87 insertions(+), 88 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index d2e9020746..18e9d0ad52 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,4 +1,91 @@ +=============================================================== + +Tag name: +Originator(s): eaton +Date: +One-line Summary: Limit vertical domain used by COSP. +Github PR URL: https://github.com/ESCOMP/CAM/pull/1010 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +The COSP simulator was not working with "FMT" compsets. This compset has a +model top of about 1 Pa which is above where the cloud parameterizations +operate. The COSP interface routine was modified so that COSP operates on +the same vertical domain as the cloud parameterizations which is set the +the namelist variable trop_cloud_top_press (1 mb by default). Changing to +a dynamically determined top required moving the call to COSP's +initialization. In addition a lot of code cleanup was done, and a bug fix +was made for the layer interface values of height and pressure passed from +CAM to COSP. + +. resolves #967- COSP prevents running "FMT" compsets. + +Removed old tools for topo file generation. + +. resolves #1005 - Remove old topo generation software from CAM + +Describe any changes made to build system: none + +Describe any changes made to the namelist: none + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: not measured, but COSP +should be less expensive in models with tops above 1 mb. + +Code reviewed by: cacraig + +List all files eliminated: +tools/definehires/* +tools/definesurf/* +tools/topo_tool/* +. these tools for topo file generation have been replaced by + https://github.com/NCAR/Topo + +List all files added and what they do: none + +List all existing files that have been modified, and describe the changes: + +src/control/cam_history_support.F90 +. fix log output format + +src/physics/cam/cospsimulator_intr.F90 +. set top of data operated on by COSP using trop_cloud_top_lev +. cospsimulator_intr_register + - move the setcosp2values call here. That routine contains the call to + COSP's initialization. +. cospsimulator_intr_readnl + - move the call to setcosp2values to cospsimulator_intr_register. +. remove outdated and/or unhelpful comments +. remove unused variables +. remove added history fields that had no corresponding outfld calls +. remove array section notation from places where the whole array is used + +src/physics/cam/ref_pres.F90 +. add calls to create vertical coordinate variables for the domain bounded + by trop_cloud_lev_top. Some COSP history fields need this coordinate. + +src/utils/hycoef.F90 +. add comment and fix a comment + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + +izumi/nag/aux_cam: + +izumi/gnu/aux_cam: + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: BFB. Some COSP diagnostic fields have +answer changes due to a bug fix in the data sent to COSP. +=============================================================== =============================================================== Tag name: cam6_3_160 @@ -193,94 +280,6 @@ izumi/gnu/aux_cam: all BFB =============================================================== =============================================================== -Tag name: -Originator(s): eaton -Date: -One-line Summary: Limit vertical domain used by COSP. -Github PR URL: https://github.com/ESCOMP/CAM/pull/1010 - -Purpose of changes (include the issue number and title text for each relevant GitHub issue): - -The COSP simulator was not working with "FMT" compsets. This compset has a -model top of about 1 Pa which is above where the cloud parameterizations -operate. The COSP interface routine was modified so that COSP operates on -the same vertical domain as the cloud parameterizations which is set the -the namelist variable trop_cloud_top_press (1 mb by default). Changing to -a dynamically determined top required moving the call to COSP's -initialization. In addition a lot of code cleanup was done, and a bug fix -was made for the layer interface values of height and pressure passed from -CAM to COSP. - -. resolves #967- COSP prevents running "FMT" compsets. - -Removed old tools for topo file generation. - -. resolves #1005 - Remove old topo generation software from CAM - -Describe any changes made to build system: none - -Describe any changes made to the namelist: none - -List any changes to the defaults for the boundary datasets: none - -Describe any substantial timing or memory changes: not measured, but COSP -should be less expensive in models with tops above 1 mb. - -Code reviewed by: - -List all files eliminated: -tools/definehires/* -tools/definesurf/* -tools/topo_tool/* -. these tools for topo file generation have been replaced by - https://github.com/NCAR/Topo - -List all files added and what they do: none - -List all existing files that have been modified, and describe the changes: - -src/control/cam_history_support.F90 -. fix log output format - -src/physics/cam/cospsimulator_intr.F90 -. set top of data operated on by COSP using trop_cloud_top_lev -. cospsimulator_intr_register - - move the setcosp2values call here. That routine contains the call to - COSP's initialization. -. cospsimulator_intr_readnl - - move the call to setcosp2values to cospsimulator_intr_register. -. remove outdated and/or unhelpful comments -. remove unused variables -. remove added history fields that had no corresponding outfld calls -. remove array section notation from places where the whole array is used - -src/physics/cam/ref_pres.F90 -. add calls to create vertical coordinate variables for the domain bounded - by trop_cloud_lev_top. Some COSP history fields need this coordinate. - -src/utils/hycoef.F90 -. add comment and fix a comment - -If there were any failures reported from running test_driver.sh on any test -platform, and checkin with these failures has been OK'd by the gatekeeper, -then copy the lines from the td.*.status files for the failed tests to the -appropriate machine below. All failed tests must be justified. - -derecho/intel/aux_cam: - -izumi/nag/aux_cam: - -izumi/gnu/aux_cam: - -CAM tag used for the baseline comparison tests if different than previous -tag: - -Summarize any changes to answers: BFB. Some COSP diagnostic fields have -answer changes due to a bug fix in the data sent to COSP. - -=============================================================== -=============================================================== - Tag name: cam6_3_157 Originator(s): jet Date: Apr 17, 2024 From 267a37f5dc1a7d6ac79175827fb831cb42a37cc3 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 28 May 2024 11:24:11 -0400 Subject: [PATCH 14/17] fix typo in comment --- src/physics/cam/cospsimulator_intr.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index c1086a213b..603a1ce579 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -1730,7 +1730,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & call t_startf("subsample_and_optics") ! The arrays passed here contain only active columns and the limited vertical - ! domain operated on by COSP. Unsubscripted array arguments have alread been + ! domain operated on by COSP. Unsubscripted array arguments have already been ! allocated to the correct size. Arrays the size of a CAM chunk (pcol,pver) ! need to pass the correct section (:ncol,ktop:pver). call subsample_and_optics( & From 9ebd4be3cf9de171c811029109a9b7adfa991308 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 1 Jul 2024 12:00:53 -0400 Subject: [PATCH 15/17] address review comments --- doc/ChangeLog | 2 +- src/physics/cam/cospsimulator_intr.F90 | 194 +++++++++++-------------- src/physics/cam/ref_pres.F90 | 2 +- 3 files changed, 83 insertions(+), 115 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 18e9d0ad52..bcfc16294c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -11,7 +11,7 @@ Purpose of changes (include the issue number and title text for each relevant Gi The COSP simulator was not working with "FMT" compsets. This compset has a model top of about 1 Pa which is above where the cloud parameterizations operate. The COSP interface routine was modified so that COSP operates on -the same vertical domain as the cloud parameterizations which is set the +the same vertical domain as the cloud parameterizations which is set by the namelist variable trop_cloud_top_press (1 mb by default). Changing to a dynamically determined top required moving the call to COSP's initialization. In addition a lot of code cleanup was done, and a bug fix diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 603a1ce579..e4fbb5e052 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -526,7 +526,7 @@ subroutine cospsimulator_intr_init() character(len=*), parameter :: sub = 'cospsimulator_intr_init' !--------------------------------------------------------------------------- - ! The COSP init method was run from cospsimulator_intr_register in order to add + ! The COSP init method (setcosp2values) was run from cospsimulator_intr_register in order to add ! the history coordinate variables earlier as needed for the restart time sequencing. ! ISCCP OUTPUTS @@ -576,7 +576,7 @@ subroutine cospsimulator_intr_init() 'PARASOL-like mono-directional reflectance ', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CFAD_SR532_CAL', (/'cosp_sr','cosp_ht'/), 'A', 'fraction', & 'Calipso Scattering Ratio CFAD (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('MOL532_CAL', (/'trop_pref'/), 'A', 'm-1sr-1', & + call addfld('MOL532_CAL', (/'trop_pref'/), 'A', 'm-1 sr-1', & 'Calipso Molecular Backscatter (532 nm) ', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('ATB532_CAL', (/'cosp_scol','trop_pref'/), 'I', 'no_unit_log10(x)', & 'Calipso Attenuated Total Backscatter (532 nm) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF) @@ -586,14 +586,14 @@ subroutine cospsimulator_intr_init() 'Calipso Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLD_CAL_UN', (/'cosp_ht'/), 'A', 'percent', & 'Calipso Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CLD_CAL_TMP', (/'cosp_ht'/), 'A', 'percent', & - 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CLD_CAL_TMPLIQ', (/'cosp_ht'/), 'A', 'percent', & - 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CLD_CAL_TMPICE', (/'cosp_ht'/), 'A', 'percent', & - 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld('CLD_CAL_TMPUN', (/'cosp_ht'/), 'A', 'percent', & - 'NOT SURE WHAT THIS IS Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMP', (/'cosp_ht'/), 'A', 'K', & + 'Calipso Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMPLIQ', (/'cosp_ht'/), 'A', 'K', & + 'Calipso Liquid Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMPICE', (/'cosp_ht'/), 'A', 'K', & + 'Calipso Ice Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld('CLD_CAL_TMPUN', (/'cosp_ht'/), 'A', 'K', & + 'Calipso Undefined-Phase Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLDTOT_CAL_ICE', horiz_only, 'A', 'percent', & 'Calipso Total Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLDTOT_CAL_LIQ', horiz_only, 'A', 'percent', & @@ -759,11 +759,11 @@ subroutine cospsimulator_intr_init() call addfld('IWPMODIS', horiz_only, 'A', 'kg m-2', & 'MODIS Cloud Ice Water Path*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLMODIS', (/'cosp_tau_modis','cosp_prs '/), 'A', '%', & - 'MODIS Cloud Area Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + 'MODIS Cloud Area Fraction (tau-pressure histogram)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLRIMODIS', (/'cosp_tau_modis','cosp_reffice '/), 'A', '%', & - 'MODIS Cloud Area Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + 'MODIS Cloud Area Fraction (tau-reffice histogram)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld('CLRLMODIS', (/'cosp_tau_modis','cosp_reffliq '/), 'A', '%', & - 'MODIS Cloud Area Fraction', flag_xyfill=.true., fill_value=R_UNDEF) + 'MODIS Cloud Area Fraction (tau-reffliq histogram)', flag_xyfill=.true., fill_value=R_UNDEF) call add_default('CLTMODIS',cosp_histfile_num,' ') call add_default('CLWMODIS',cosp_histfile_num,' ') @@ -811,21 +811,21 @@ subroutine cospsimulator_intr_init() !! ADDFLD, ADD_DEFAULT, OUTFLD CALLS FOR COSP OUTPUTS IF RUNNING COSP OFF-LINE if (cosp_histfile_aux) then call addfld ('PS_COSP', horiz_only, 'I','Pa', & - 'PS_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Surface Pressure', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('TS_COSP', horiz_only, 'I','K', & - 'TS_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Skin Temperature', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('P_COSP', (/ 'trop_pref'/), 'I','Pa', & - 'P_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Pressure (layer midpoint)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('PH_COSP', (/ 'trop_prefi'/), 'I','Pa', & - 'PH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Pressure (layer interface)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('ZLEV_COSP', (/ 'trop_pref'/), 'I','m', & - 'ZLEV_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Height (layer midpoint)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('ZLEV_HALF_COSP', (/ 'trop_prefi'/), 'I','m', & - 'ZLEV_HALF_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Height (layer interface)', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('T_COSP', (/ 'trop_pref'/), 'I','K', & - 'T_COSP', flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('RH_COSP', (/ 'trop_pref'/), 'I','percent', & - 'RH_COSP', flag_xyfill=.true., fill_value=R_UNDEF) + 'COSP Temperature', flag_xyfill=.true., fill_value=R_UNDEF) + call addfld ('Q_COSP', (/ 'trop_pref'/), 'I','percent', & + 'COSP Specific Humidity', flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('TAU_067', (/'cosp_scol','trop_pref'/), 'I','1', & 'Subcolumn 0.67micron optical depth', flag_xyfill=.true., fill_value=R_UNDEF) @@ -851,7 +851,7 @@ subroutine cospsimulator_intr_init() call add_default('ZLEV_COSP', cosp_histfile_aux_num,' ') call add_default('ZLEV_HALF_COSP', cosp_histfile_aux_num,' ') call add_default('T_COSP', cosp_histfile_aux_num,' ') - call add_default('RH_COSP', cosp_histfile_aux_num,' ') + call add_default('Q_COSP', cosp_histfile_aux_num,' ') call add_default('TAU_067', cosp_histfile_aux_num,' ') call add_default('EMISS_11', cosp_histfile_aux_num,' ') call add_default('MODIS_fracliq', cosp_histfile_aux_num,' ') @@ -935,7 +935,7 @@ subroutine setcosp2values() call quickbeam_optics_init() ! DS2017: The setting up of the vertical grid for regridding the CALIPSO and Cloudsat products is - ! now donein cosp_init, but these fields are stored in cosp_config.F90. + ! now done in cosp_init, but these fields are stored in cosp_config.F90. ! Additionally all static fields used by the individual simulators are set up by calls ! to _init functions in cosp_init. ! DS2019: Add logicals, default=.false., for new Lidar simuldators (Earthcare (atlid) and ground-based @@ -1010,7 +1010,7 @@ subroutine setcosp2values() ! next, assign collapsed reference vectors for cam_history.F90 ! convention for saving output = prs1,tau1 ... prs1,tau7 ; prs2,tau1 ... prs2,tau7 etc. - ! actual output is specified in cospsimulator1_intr.F90 + ! actual output is specified in cospsimulator_intr_init. do k=1,nprs_cosp prstau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp) prstau_prsmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=prsmid_cosp(k) @@ -1053,7 +1053,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & use constituents, only: cnst_get_ind use rad_constituents, only: rad_cnst_get_gas use interpolate_data, only: lininterp_init,lininterp,lininterp_finish,interp_type - use physconst, only: pi, gravit + use physconst, only: pi, inverse_gravit => rga use cam_history, only: outfld,hist_fld_col_active use cam_history_support, only: max_fieldname_len @@ -1089,6 +1089,8 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & integer :: isc integer :: is integer :: id + + real(r8), parameter :: rad2deg = 180._r8/pi ! Microphysics variables integer :: ixcldliq ! cloud liquid amount index for state%q @@ -1101,9 +1103,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! COSP input variables that depend on CAM integer :: Npoints ! Number of gridpoints COSP will process - logical :: use_reff ! True if effective radius to be used by radar simulator - ! (always used by lidar) - logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm real(r8), parameter :: emsfc_lw = 0.99_r8 ! longwave emissivity of surface at 10.5 microns ! Local vars related to calculations to go from CAM input to COSP input @@ -1564,7 +1563,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! add surface height (surface geopotential/gravity) to convert CAM heights based on ! geopotential above surface into height above sea level - surf_hgt = state%phis(:ncol)/gravit + surf_hgt = state%phis(:ncol)*inverse_gravit do k = 1, nlay zmid(:,k) = state%zm(:ncol,ktop+k-1) + surf_hgt zint(:,k) = state%zi(:ncol,ktop+k-1) + surf_hgt @@ -1576,13 +1575,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & if (cam_in%landfrac(i) > 0.01_r8) landmask(i)= 1 end do - ! calculate necessary input cloud/precip variables - ! CAM4 note: don't take the cloud water from the hack shallow convection scheme or the deep convection. - ! cloud water values for convection are the same as the stratiform value. (Sungsu) - ! all precip fluxes are mid points, all values are grid-box mean ("gbm") (Yuying) - - use_precipitation_fluxes = .true. !!! consistent with cam4 implementation. - ! Add together deep and shallow convection precipitation fluxes. ! Note: sh_flxprc and dp_flxprc variables are rain+snow rain_cv = (sh_flxprc(:ncol,ktop:pverp) - sh_flxsnw(:ncol,ktop:pverp)) + & @@ -1644,9 +1636,6 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & end do end do - !! if use_reff=.false. then all sizes use DEFAULT_LIDAR_REFF = 30.0e-6 meters - use_reff = .true. - !! The specification of reff_cosp now follows e-mail discussion with Yuying in January 2011. !! The values from the physics buffer are in microns... convert to meters for COSP. reff_cosp(:,:,I_LSCLIQ) = rel(:ncol,ktop:pver)*1.e-6_r8 @@ -1706,8 +1695,8 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & call construct_cospstateIN(ncol, nlay, 0, cospstateIN) ! convert to degrees. Lat in range [-90,..,90], Lon in range [0,..,360] - cospstateIN%lat = state%lat(:ncol)*180._r8/pi - cospstateIN%lon = state%lon(:ncol)*180._r8/pi + cospstateIN%lat = state%lat(:ncol)*rad2deg + cospstateIN%lon = state%lon(:ncol)*rad2deg cospstateIN%at = state%t(:ncol,ktop:pver) cospstateIN%qv = q(:ncol,ktop:pver) cospstateIN%o3 = o3(:ncol,ktop:pver) @@ -1735,7 +1724,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & ! need to pass the correct section (:ncol,ktop:pver). call subsample_and_optics( & ncol, nlay, nscol_cosp, nhydro, overlap, & - use_precipitation_fluxes, lidar_ice_type,sd_cs(lchnk), & + lidar_ice_type, sd_cs(lchnk), & cld(:ncol,ktop:pver), concld(:ncol,ktop:pver), & rain_ls_interp, snow_ls_interp, grpl_ls_interp, rain_cv_interp, & snow_cv_interp, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, & @@ -1777,7 +1766,7 @@ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & call outfld('ZLEV_COSP', cospstateIN%hgt_matrix, ncol,lchnk) call outfld('ZLEV_HALF_COSP', cospstateIN%hgt_matrix_half, ncol,lchnk) call outfld('T_COSP', cospstateIN%at, ncol,lchnk) - call outfld('RH_COSP', cospstateIN%qv, ncol,lchnk) + call outfld('Q_COSP', cospstateIN%qv, ncol,lchnk) ! 3D outputs, but first compress to 2D do i=1,ncol @@ -2350,7 +2339,7 @@ end subroutine cospsimulator_intr_run ! SUBROUTINE subsample_and_optics ! ###################################################################################### subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, & - use_precipitation_fluxes, lidar_ice_type, sd, tca, cca,& + lidar_ice_type, sd, tca, cca, & fl_lsrainIN, fl_lssnowIN, fl_lsgrplIN, fl_ccrainIN, & fl_ccsnowIN, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, & reffIN, dtau_c, dtau_s, dem_c, dem_s, dtau_s_snow, & @@ -2368,8 +2357,6 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, use mod_cosp_config, only: Nlvgrid, vgrid_zl, vgrid_zu use mod_cosp_stats, only: cosp_change_vertical_grid ! Inputs - logical,intent(in) :: & - use_precipitation_fluxes integer,intent(in) :: & nPoints, & ! Number of gridpoints nLevels, & ! Number of vertical levels @@ -2446,17 +2433,11 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, call scops(NPoints,Nlevels,Ncolumns,rngs,tca,cca,overlap,cospIN%frac_out,0) deallocate(seed,rngs) - ! Sum up precipitation rates. If not using preciitation fluxes, mixing ratios are - ! stored in _rate variables. + ! Sum up precipitation rates. allocate(ls_p_rate(nPoints,nLevels), cv_p_rate(nPoints,Nlevels), stat=istat) call handle_allocate_error(istat, sub, 'ls_p_rate, cv_p_rate') - if(use_precipitation_fluxes) then - ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN - cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN - else - ls_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) + mixing_ratio (groupel) - cv_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) - endif + ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN + cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN ! Call PREC_SCOPS allocate(frac_prec(nPoints,nColumns,nLevels), stat=istat) @@ -2567,26 +2548,14 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, endif ! Precipitation - if (use_precipitation_fluxes) then - if (prec_ls(j,k) .ne. 0._r8) then - fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k) - fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k) - fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k) - endif - if (prec_cv(j,k) .ne. 0._r8) then - fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k) - fl_ccsnow(j,k) = fl_ccsnowIN(j,k)/prec_cv(j,k) - endif - else - if (prec_ls(j,k) .ne. 0._r8) then - mr_hydro(j,:,k,I_LSRAIN) = mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k) - mr_hydro(j,:,k,I_LSSNOW) = mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k) - mr_hydro(j,:,k,I_LSGRPL) = mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k) - endif - if (prec_cv(j,k) .ne. 0._r8) then - mr_hydro(j,:,k,I_CVRAIN) = mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k) - mr_hydro(j,:,k,I_CVSNOW) = mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k) - endif + if (prec_ls(j,k) .ne. 0._r8) then + fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k) + fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k) + fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0._r8) then + fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k) + fl_ccsnow(j,k) = fl_ccsnowIN(j,k)/prec_cv(j,k) endif enddo enddo @@ -2594,43 +2563,42 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! Convert precipitation fluxes to mixing ratios !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - if (use_precipitation_fluxes) then - ! LS rain - call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & - cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSRAIN), n_bx(I_LSRAIN), & - alpha_x(I_LSRAIN), c_x(I_LSRAIN), d_x(I_LSRAIN), g_x(I_LSRAIN), & - a_x(I_LSRAIN), b_x(I_LSRAIN), gamma_1(I_LSRAIN), gamma_2(I_LSRAIN), & - gamma_3(I_LSRAIN), gamma_4(I_LSRAIN), fl_lsrain, & - mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN)) - ! LS snow - call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & - cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSSNOW), n_bx(I_LSSNOW), & - alpha_x(I_LSSNOW), c_x(I_LSSNOW), d_x(I_LSSNOW), g_x(I_LSSNOW), & - a_x(I_LSSNOW), b_x(I_LSSNOW), gamma_1(I_LSSNOW), gamma_2(I_LSSNOW), & - gamma_3(I_LSSNOW), gamma_4(I_LSSNOW), fl_lssnow, & - mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW)) - ! CV rain - call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & - cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVRAIN), n_bx(I_CVRAIN), & - alpha_x(I_CVRAIN), c_x(I_CVRAIN), d_x(I_CVRAIN), g_x(I_CVRAIN), & - a_x(I_CVRAIN), b_x(I_CVRAIN), gamma_1(I_CVRAIN), gamma_2(I_CVRAIN), & - gamma_3(I_CVRAIN), gamma_4(I_CVRAIN), fl_ccrain, & - mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN)) - ! CV snow - call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & - cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVSNOW), n_bx(I_CVSNOW), & - alpha_x(I_CVSNOW), c_x(I_CVSNOW), d_x(I_CVSNOW), g_x(I_CVSNOW), & - a_x(I_CVSNOW), b_x(I_CVSNOW), gamma_1(I_CVSNOW), gamma_2(I_CVSNOW), & - gamma_3(I_CVSNOW), gamma_4(I_CVSNOW), fl_ccsnow, & - mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW)) - ! LS groupel. - call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & - cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSGRPL), n_bx(I_LSGRPL), & - alpha_x(I_LSGRPL), c_x(I_LSGRPL), d_x(I_LSGRPL), g_x(I_LSGRPL), & - a_x(I_LSGRPL), b_x(I_LSGRPL), gamma_1(I_LSGRPL), gamma_2(I_LSGRPL), & - gamma_3(I_LSGRPL), gamma_4(I_LSGRPL), fl_lsgrpl, & - mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL)) - endif + + ! LS rain + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSRAIN), n_bx(I_LSRAIN), & + alpha_x(I_LSRAIN), c_x(I_LSRAIN), d_x(I_LSRAIN), g_x(I_LSRAIN), & + a_x(I_LSRAIN), b_x(I_LSRAIN), gamma_1(I_LSRAIN), gamma_2(I_LSRAIN), & + gamma_3(I_LSRAIN), gamma_4(I_LSRAIN), fl_lsrain, & + mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN)) + ! LS snow + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSSNOW), n_bx(I_LSSNOW), & + alpha_x(I_LSSNOW), c_x(I_LSSNOW), d_x(I_LSSNOW), g_x(I_LSSNOW), & + a_x(I_LSSNOW), b_x(I_LSSNOW), gamma_1(I_LSSNOW), gamma_2(I_LSSNOW), & + gamma_3(I_LSSNOW), gamma_4(I_LSSNOW), fl_lssnow, & + mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW)) + ! CV rain + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVRAIN), n_bx(I_CVRAIN), & + alpha_x(I_CVRAIN), c_x(I_CVRAIN), d_x(I_CVRAIN), g_x(I_CVRAIN), & + a_x(I_CVRAIN), b_x(I_CVRAIN), gamma_1(I_CVRAIN), gamma_2(I_CVRAIN), & + gamma_3(I_CVRAIN), gamma_4(I_CVRAIN), fl_ccrain, & + mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN)) + ! CV snow + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVSNOW), n_bx(I_CVSNOW), & + alpha_x(I_CVSNOW), c_x(I_CVSNOW), d_x(I_CVSNOW), g_x(I_CVSNOW), & + a_x(I_CVSNOW), b_x(I_CVSNOW), gamma_1(I_CVSNOW), gamma_2(I_CVSNOW), & + gamma_3(I_CVSNOW), gamma_4(I_CVSNOW), fl_ccsnow, & + mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW)) + ! LS groupel. + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSGRPL), n_bx(I_LSGRPL), & + alpha_x(I_LSGRPL), c_x(I_LSGRPL), d_x(I_LSGRPL), g_x(I_LSGRPL), & + a_x(I_LSGRPL), b_x(I_LSGRPL), gamma_1(I_LSGRPL), gamma_2(I_LSGRPL), & + gamma_3(I_LSGRPL), gamma_4(I_LSGRPL), fl_lsgrpl, & + mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL)) else cospIN%frac_out(:,:,:) = 1 diff --git a/src/physics/cam/ref_pres.F90 b/src/physics/cam/ref_pres.F90 index 1ffdbc73b5..1630072d3e 100644 --- a/src/physics/cam/ref_pres.F90 +++ b/src/physics/cam/ref_pres.F90 @@ -162,7 +162,7 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in) 'hPa', trop_pref, positive='down') allocate(trop_prefi(nlev+1), stat=istat) - call alloc_err(istat, sub, 'trop_prefi', nlev) + call alloc_err(istat, sub, 'trop_prefi', nlev+1) trop_prefi = pref_edge(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa call add_vert_coord('trop_prefi', nlev+1, 'troposphere reference pressures (interfaces)', & From b21081530655cb0407a46007f26471f4068c2ec7 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 1 Jul 2024 14:15:31 -0400 Subject: [PATCH 16/17] fix misplaced USE_COSP ifdef --- src/physics/cam/cospsimulator_intr.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index e4fbb5e052..7db2792a12 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -441,6 +441,7 @@ subroutine cospsimulator_intr_register() use cam_history_support, only: add_hist_coord !--------------------------------------------------------------------------- +#ifdef USE_COSP ! Set number of levels used by COSP to the number of levels used by ! CAM's cloud macro/microphysics parameterizations. nlay = pver - ktop + 1 @@ -449,7 +450,6 @@ subroutine cospsimulator_intr_register() ! Set COSP coordinate arrays call setcosp2values() -#ifdef USE_COSP ! Define coordinate variables for COSP outputs. if (lisccp_sim .or. lmodis_sim) then call add_hist_coord('cosp_prs', nprs_cosp, 'COSP Mean ISCCP pressure', & From bffdd2ea3e5ee294451ce2effd23e31c6556e7df Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 1 Jul 2024 17:50:49 -0400 Subject: [PATCH 17/17] update ChangeLog --- doc/ChangeLog | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 0d23eaee29..320ee73134 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,7 +2,7 @@ Tag name: cam6_4_005 Originator(s): eaton -Date: +Date: 1 July 2024 One-line Summary: Limit vertical domain used by COSP. Github PR URL: https://github.com/ESCOMP/CAM/pull/1010 @@ -73,17 +73,26 @@ platform, and checkin with these failures has been OK'd by the gatekeeper, then copy the lines from the td.*.status files for the failed tests to the appropriate machine below. All failed tests must be justified. -derecho/intel/aux_cam: +derecho/intel/aux_cam: All PASS except: +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) +SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND) +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) +SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) +SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) +- pre-existing failures -izumi/nag/aux_cam: +izumi/nag/aux_cam: All PASS except: +DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: PEND) +- pre-existing failure -izumi/gnu/aux_cam: +izumi/gnu/aux_cam: All PASS. CAM tag used for the baseline comparison tests if different than previous tag: -Summarize any changes to answers: BFB. Some COSP diagnostic fields have -answer changes due to a bug fix in the data sent to COSP. +Summarize any changes to answers: BFB. Note that although the regression + tests with COSP diagnostics passed, there are some COSP diagnostic fields that + have answer changes due to a bug fix in the data sent to COSP. =============================================================== ===============================================================