diff --git a/modulefiles/ursa.intel-run.lua b/modulefiles/ursa.intel-run.lua index d212e55c..50a85bd7 100644 --- a/modulefiles/ursa.intel-run.lua +++ b/modulefiles/ursa.intel-run.lua @@ -2,17 +2,19 @@ help([[ ]]) -- Spack Stack installation specs -prepend_path("MODULEPATH", "/apps/contrib/spack-stack/spack-stack-1.9.2/envs/ue-oneapi-2024.2.1/install/modulefiles/Core") +prepend_path("MODULEPATH", "/contrib/spack-stack/spack-stack-1.9.2/envs/ue-oneapi-2024.2.1/install/modulefiles/Core") local stack_oneapi_ver=os.getenv("stack_oneapi_ver") or "2024.2.1" local stack_intel_oneapi_mpi_ver=os.getenv("stack_intel_oneapi_mpi_ver") or "2021.13" local grads_ver=os.getenv("grads_ver") or "2.2.3" +local tar_ver=os.getenv("tar_ver") or "1.34" load(pathJoin("stack-oneapi", stack_oneapi_ver)) -load(pathJoin("stack-intel-oneapi-mpi", stack_intel_oneapi_mpiver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_intel_oneapi_mpi_ver)) load(pathJoin("grads", grads_ver)) +load(pathJoin("tar", tar_ver)) load("common-run") diff --git a/modulefiles/ursa.intel.lua b/modulefiles/ursa.intel.lua index db34d49e..5c505d75 100644 --- a/modulefiles/ursa.intel.lua +++ b/modulefiles/ursa.intel.lua @@ -1,14 +1,15 @@ help([[ ]]) + -- Spack Stack installation specs prepend_path("MODULEPATH", "/contrib/spack-stack/spack-stack-1.9.2/envs/ue-oneapi-2024.2.1/install/modulefiles/Core") local stack_oneapi_ver=os.getenv("stack_oneapi_ver") or "2024.2.1" -local stack_intel_oneapi_mpi=os.getenv("stack_intel_oneapi_mpi") or "2021.13" +local stack_intel_oneapi_mpi_ver=os.getenv("stack_intel_oneapi_mpi_ver") or "2021.13" load(pathJoin("stack-oneapi", stack_oneapi_ver)) -load(pathJoin("stack-intel-oneapi-mpi", stack_intel_oneapi_mpi)) +load(pathJoin("stack-intel-oneapi-mpi", stack_intel_oneapi_mpi_ver)) load("common") diff --git a/parm/Mon_config b/parm/Mon_config index e035c035..f2065531 100644 --- a/parm/Mon_config +++ b/parm/Mon_config @@ -31,7 +31,8 @@ export MY_MACHINE=$machine_id # then I'll open an issue for the change to those machines. # if [[ $MY_MACHINE = "wcoss2" || $MY_MACHINE = "hera" || $MY_MACHINE = "orion" || \ - $MY_MACHINE = "hercules" || $MY_MACHINE = "s4" || $MY_MACHINE = "jet" ]]; then + $MY_MACHINE = "hercules" || $MY_MACHINE = "s4" || $MY_MACHINE = "jet" || \ + $MY_MACHINE = "ursa" ]]; then source $DIR_ROOT/ush/module-setup.sh module use $DIR_ROOT/modulefiles module load ${MACHINE_ID}.${COMPILER}-run @@ -82,6 +83,17 @@ case $MY_MACHINE in account="da-cpu" ;; + ursa) + export SUB=/apps/slurm/default/bin/sbatch + + tankdir="/scratch3/NCEPDEV/da/$USER/save/nbns" + ptmp="/scratch3/NCEPDEV/stmp/$USER" + stmp="/scratch3/NCEPDEV/stmp/$USER" + queue="" + project="" + account="da-cpu" + ;; + wcoss2) export SUB="qsub" diff --git a/src/Conventional_Monitor/data_extract/ush/ConMon_DE.sh b/src/Conventional_Monitor/data_extract/ush/ConMon_DE.sh index adef543b..a5203ea6 100755 --- a/src/Conventional_Monitor/data_extract/ush/ConMon_DE.sh +++ b/src/Conventional_Monitor/data_extract/ush/ConMon_DE.sh @@ -197,6 +197,16 @@ if [[ -e ${C_TANKDIR}/info/gdas_conmon_base.txt ]]; then export conmon_base=${C_TANKDIR}/info/gdas_conmon_base.txt fi +if [ ! -s $cnvstat ]; then + echo "unable to access $cnvstat" +fi + +if [ ! -s $pgrbf00 ]; then + echo "unable to access $pgrbf00" +fi +if [ ! -s $pgrbf06 ]; then + echo "unable to access $pgrbf06" +fi exit_value=0 if [ -s $cnvstat -a -s $pgrbf00 -a -s $pgrbf06 ]; then @@ -205,7 +215,6 @@ if [ -s $cnvstat -a -s $pgrbf00 -a -s $pgrbf06 ]; then #------------------------------------------------------------------ if [ -s $pgrbf06 ]; then - echo "Ok to proceed with DE" logdir=${C_LOGDIR} if [[ ! -d ${logdir} ]]; then mkdir -p ${logdir} @@ -221,6 +230,11 @@ if [ -s $cnvstat -a -s $pgrbf00 -a -s $pgrbf06 ]; then $SUB -A $ACCOUNT --ntasks=1 --time=00:30:00 \ -p ${SERVICE_PARTITION} -J ${jobname} -o $C_LOGDIR/DE.${PDY}.${CYC}.log \ ${HOMEgdas_conmon}/jobs/JGDAS_ATMOS_CONMON + + elif [[ $MY_MACHINE = "ursa" ]]; then + $SUB -A $ACCOUNT --ntasks=1 --time=01:30:00 \ + -J ${jobname} -o $C_LOGDIR/DE.${PDY}.${CYC}.log \ + ${HOMEgdas_conmon}/jobs/JGDAS_ATMOS_CONMON elif [[ $MY_MACHINE = "jet" ]]; then $SUB -A $ACCOUNT -ntasks=1 --time=00:30:00 --mem=5000 \ @@ -228,7 +242,7 @@ if [ -s $cnvstat -a -s $pgrbf00 -a -s $pgrbf06 ]; then ${HOMEgdas_conmon}/jobs/JGDAS_ATMOS_CONMON elif [[ $MY_MACHINE = "wcoss2" ]]; then - $SUB -V -q $JOB_QUEUE -A $ACCOUNT -o ${logfile} -e ${logfile} -l walltime=45:00 -N ${jobname} \ + $SUB -V -q $JOB_QUEUE -A $ACCOUNT -o ${logfile} -e ${logfile} -l walltime=2:15:00 -N ${jobname} \ -l select=1:mem=8gb ${HOMEgdas_conmon}/jobs/JGDAS_ATMOS_CONMON fi diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/conmon_read_diag.F90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/conmon_read_diag.F90 index f6d4f114..8b4ae388 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/conmon_read_diag.F90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/conmon_read_diag.F90 @@ -159,7 +159,7 @@ subroutine conmon_read_diag_file( input_file, ctype, intype, expected_nreal, nob if ( netcdf ) then write(6,*) ' call nc read subroutine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) end if @@ -205,7 +205,7 @@ subroutine conmon_return_all_obs( input_file, ctype, nobs, list ) ! if ( netcdf ) then write(6,*) ' call nc retrieve all routine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else write(6,*) ' call bin retrieve all routine' call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) @@ -221,13 +221,13 @@ end subroutine conmon_return_all_obs ! ! NetCDF read routine !------------------------------- - subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) !--- interface character(100), intent(in) :: input_file logical, intent(in) :: return_all character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -267,22 +267,22 @@ subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nr select case ( trim( adjustl( ctype ) ) ) case ( 'gps' ) - call read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'ps' ) - call read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'q' ) - call read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'sst' ) - call read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 't' ) - call read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'uv' ) - call read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case default print *, 'ERROR: unmatched ctype :', ctype @@ -315,21 +315,20 @@ end subroutine read_diag_file_nc !--------------------------------------------------------- ! netcdf read routine for ps data types in netcdf files ! - subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_ps_nc( return_all, ftin, ctype, intype,nobs,in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -365,7 +364,8 @@ subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,exp ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -517,21 +517,20 @@ end subroutine read_diag_file_ps_nc !--------------------------------------------------------- ! netcdf read routine for q data types in netcdf files ! - subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_q_nc( return_all, ftin, ctype, intype,nobs,in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -568,7 +567,8 @@ subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expe ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -731,21 +731,20 @@ end subroutine read_diag_file_q_nc ! NOTE2: There are known discrepencies between the contents ! of sst obs in binary and NetCDF files. ! - subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_sst_nc( return_all, ftin, ctype, intype,nobs,in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -785,7 +784,8 @@ subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,ex ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -960,14 +960,13 @@ end subroutine read_diag_file_sst_nc !--------------------------------------------------------- ! netcdf read routine for t data types in netcdf files ! - subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1004,16 +1003,14 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp real(r_single), dimension(:), allocatable :: Data_Pof ! (obs) real(r_single), dimension(:), allocatable :: Data_Vertical_Velocity ! (obs) real(r_single), dimension(:,:), allocatable :: Bias_Correction_Terms ! (nobs, Bias_Correction_Terms_arr_dim) - integer(i_kind) :: jj + integer(i_kind) :: jj, id print *, ' ' print *, ' --> read_diag_file_t_nc' - print *, ' input_file = ', input_file print *, ' ftin = ', ftin print *, ' ctype = ', ctype print *, ' intype = ', intype - print *, ' expected_nreal = ', expected_nreal print *, ' in_subtype = ', in_subtype @@ -1021,7 +1018,8 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs else print *, 'ERROR: unable to read nobs' ierr=1 @@ -1197,21 +1195,20 @@ end subroutine read_diag_file_t_nc !--------------------------------------------------------- ! netcdf read routine for uv data types in netcdf files ! - subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, id, ierr, total_obs, idx logical :: have_subtype = .true. logical :: add_obs @@ -1252,7 +1249,8 @@ subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, ex ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -1427,21 +1425,20 @@ end subroutine read_diag_file_uv_nc ! in binary and NetCDF formatted diag files. See ! comments below. ! - subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_gps_nc( return_all, ftin, ctype, intype,nobs,in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -1454,14 +1451,14 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex real(r_single), dimension(:), allocatable :: Latitude ! (obs) real(r_single), dimension(:), allocatable :: Longitude ! (obs) real(r_single), dimension(:), allocatable :: Incremental_Bending_Angle ! (obs) - real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) + !real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Pressure ! (obs) real(r_single), dimension(:), allocatable :: Height ! (obs) real(r_single), dimension(:), allocatable :: Time ! (obs) real(r_single), dimension(:), allocatable :: Model_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Setup_QC_Mark ! (obs) real(r_single), dimension(:), allocatable :: Prep_Use_Flag ! (obs) - real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) + !real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) real(r_single), dimension(:), allocatable :: Nonlinear_QC_Rel_Wgt ! (obs) real(r_single), dimension(:), allocatable :: Analysis_Use_Flag ! (obs) real(r_single), dimension(:), allocatable :: Errinv_Input ! (obs) @@ -1483,7 +1480,8 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/grads_lev.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/grads_lev.f90 index 2056af66..f8ee97dc 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/grads_lev.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/grads_lev.f90 @@ -8,7 +8,7 @@ subroutine grads_lev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& - levcard,hint,isubtype,subtype,list,run) + hint,subtype,list,run) use generic_list use data @@ -16,6 +16,8 @@ subroutine grads_lev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& implicit none external :: rm_dups + external :: getpres + type(list_node_t), pointer :: list type(list_node_t), pointer :: next => null() @@ -31,9 +33,7 @@ subroutine grads_lev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& character(3) :: run ! ges or anl character(30) :: files, filegrad, file_nobs - character(10) :: levcard - integer(4):: isubtype integer i,j,k,ctr,obs_ctr integer ilat,ilon,ipres,itime,iweight,ndup diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/maingrads_lev.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/maingrads_lev.f90 index 015aa1e5..b81a662c 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/maingrads_lev.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_lev.fd/maingrads_lev.f90 @@ -18,14 +18,13 @@ interface subroutine grads_lev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads, & - levcard,hint,isubtype,subtype,list,run) + hint,subtype,list,run) use generic_list integer ifileo character(ifileo) :: fileo - integer :: nobs,nreal,nlev,iscater,igrads,isubtype + integer :: nobs,nreal,nlev,iscater,igrads real(4),dimension(nlev) :: plev - character(10) :: levcard real*4 :: hint character(3) :: subtype type(list_node_t), pointer :: list @@ -82,16 +81,16 @@ end subroutine grads_lev if( nobs > 0 ) then if(trim(levcard) == 'alllev' ) then call grads_lev(stype,lstype,nobs,nreal,n_alllev,palllev,iscater, & - igrads,levcard,hint,isubtype,subtype,list,run) + igrads,hint,subtype,list,run) else if (trim(levcard) == 'acft' ) then call grads_lev(stype,lstype,nobs,nreal,n_acft,pacft,iscater,igrads,& - levcard,hint,isubtype,subtype,list,run) + hint,subtype,list,run) else if(trim(levcard) == 'lowlev' ) then call grads_lev(stype,lstype,nobs,nreal,n_lowlev,plowlev,iscater,& - igrads,levcard,hint,isubtype,subtype,list,run) + igrads,hint,subtype,list,run) else if(trim(levcard) == 'upair' ) then call grads_lev(stype,lstype,nobs,nreal,n_upair,pupair,iscater,& - igrads,levcard,hint,isubtype,subtype,list,run) + igrads,hint,subtype,list,run) end if else print *, 'NOBS <= 0, NO OUTPUT GENERATED' diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/conmon_read_diag.F90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/conmon_read_diag.F90 index 5ae7935f..b4162a5f 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/conmon_read_diag.F90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/conmon_read_diag.F90 @@ -159,7 +159,7 @@ subroutine conmon_read_diag_file( input_file, ctype, intype, expected_nreal, nob if ( netcdf ) then write(6,*) ' call nc read subroutine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) end if @@ -205,7 +205,7 @@ subroutine conmon_return_all_obs( input_file, ctype, nobs, list ) ! if ( netcdf ) then write(6,*) ' call nc retrieve all routine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else write(6,*) ' call bin retrieve all routine' call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) @@ -221,13 +221,13 @@ end subroutine conmon_return_all_obs ! ! NetCDF read routine !------------------------------- - subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) !--- interface character(100), intent(in) :: input_file logical, intent(in) :: return_all character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -268,22 +268,22 @@ subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nr select case ( trim( adjustl( ctype ) ) ) case ( 'gps' ) - call read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'ps' ) - call read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'q' ) - call read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'sst' ) - call read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 't' ) - call read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'uv' ) - call read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case default print *, 'ERROR: unmatched ctype :', ctype @@ -316,14 +316,13 @@ end subroutine read_diag_file_nc !--------------------------------------------------------- ! netcdf read routine for ps data types in netcdf files ! - subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -518,14 +517,13 @@ end subroutine read_diag_file_ps_nc !--------------------------------------------------------- ! netcdf read routine for q data types in netcdf files ! - subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -732,14 +730,13 @@ end subroutine read_diag_file_q_nc ! NOTE2: There are known discrepencies between the contents ! of sst obs in binary and NetCDF files. ! - subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -961,14 +958,13 @@ end subroutine read_diag_file_sst_nc !--------------------------------------------------------- ! netcdf read routine for t data types in netcdf files ! - subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1010,11 +1006,9 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp print *, ' ' print *, ' --> read_diag_file_t_nc' - print *, ' input_file = ', input_file print *, ' ftin = ', ftin print *, ' ctype = ', ctype print *, ' intype = ', intype - print *, ' expected_nreal = ', expected_nreal print *, ' in_subtype = ', in_subtype @@ -1198,14 +1192,13 @@ end subroutine read_diag_file_t_nc !--------------------------------------------------------- ! netcdf read routine for uv data types in netcdf files ! - subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1428,14 +1421,13 @@ end subroutine read_diag_file_uv_nc ! in binary and NetCDF formatted diag files. See ! comments below. ! - subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1455,14 +1447,14 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex real(r_single), dimension(:), allocatable :: Latitude ! (obs) real(r_single), dimension(:), allocatable :: Longitude ! (obs) real(r_single), dimension(:), allocatable :: Incremental_Bending_Angle ! (obs) - real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) + !real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Pressure ! (obs) real(r_single), dimension(:), allocatable :: Height ! (obs) real(r_single), dimension(:), allocatable :: Time ! (obs) real(r_single), dimension(:), allocatable :: Model_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Setup_QC_Mark ! (obs) real(r_single), dimension(:), allocatable :: Prep_Use_Flag ! (obs) - real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) + !real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) real(r_single), dimension(:), allocatable :: Nonlinear_QC_Rel_Wgt ! (obs) real(r_single), dimension(:), allocatable :: Analysis_Use_Flag ! (obs) real(r_single), dimension(:), allocatable :: Errinv_Input ! (obs) diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/grads_mandlev.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/grads_mandlev.f90 index 921d6286..10ee4488 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/grads_mandlev.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/grads_mandlev.f90 @@ -7,7 +7,7 @@ !------------------------------------------------------------- subroutine grads_mandlev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& - isubtype,subtype,list,run) + subtype,list,run) use generic_list use data @@ -15,6 +15,7 @@ subroutine grads_mandlev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& implicit none external :: rm_dups + external :: getlev type(list_node_t), pointer :: list type(list_node_t), pointer :: next => null() @@ -38,7 +39,6 @@ subroutine grads_mandlev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& integer :: i,j,ii,k,ctr,obs_ctr integer :: ilat,ilon,ipres,itime,iweight,ndup - integer(4) :: isubtype stid=' ' nflag0=0 diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/maingrads_mandlev.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/maingrads_mandlev.f90 index d58a32a4..e1179a4b 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/maingrads_mandlev.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_mandlev.fd/maingrads_mandlev.f90 @@ -16,14 +16,14 @@ program maingrads_mandlev interface subroutine grads_mandlev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& - isubtype,subtype,list,run) + subtype,list,run) use generic_list integer :: ifileo character(ifileo) :: fileo integer :: nobs,nreal,nlev - integer :: iscater,igrads,isubtype + integer :: iscater,igrads real(4),dimension(nlev) :: plev character(3) :: subtype type(list_node_t), pointer :: list @@ -79,7 +79,7 @@ end subroutine grads_mandlev if( nobs > 0 ) then call grads_mandlev(stype,lstype,nobs,nreal,n_mand,pmand,iscater,igrads,& - isubtype,subtype,list,run) + subtype,list,run) else print *, 'NOBS <= 0, NO OUTPUT GENERATED' end if diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/conmon_read_diag.F90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/conmon_read_diag.F90 index f6d4f114..8da33504 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/conmon_read_diag.F90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/conmon_read_diag.F90 @@ -159,7 +159,7 @@ subroutine conmon_read_diag_file( input_file, ctype, intype, expected_nreal, nob if ( netcdf ) then write(6,*) ' call nc read subroutine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) end if @@ -205,7 +205,7 @@ subroutine conmon_return_all_obs( input_file, ctype, nobs, list ) ! if ( netcdf ) then write(6,*) ' call nc retrieve all routine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else write(6,*) ' call bin retrieve all routine' call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) @@ -221,13 +221,13 @@ end subroutine conmon_return_all_obs ! ! NetCDF read routine !------------------------------- - subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) !--- interface character(100), intent(in) :: input_file logical, intent(in) :: return_all character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -267,22 +267,22 @@ subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nr select case ( trim( adjustl( ctype ) ) ) case ( 'gps' ) - call read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'ps' ) - call read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'q' ) - call read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'sst' ) - call read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 't' ) - call read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'uv' ) - call read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case default print *, 'ERROR: unmatched ctype :', ctype @@ -315,14 +315,13 @@ end subroutine read_diag_file_nc !--------------------------------------------------------- ! netcdf read routine for ps data types in netcdf files ! - subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -517,14 +516,13 @@ end subroutine read_diag_file_ps_nc !--------------------------------------------------------- ! netcdf read routine for q data types in netcdf files ! - subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -731,14 +729,13 @@ end subroutine read_diag_file_q_nc ! NOTE2: There are known discrepencies between the contents ! of sst obs in binary and NetCDF files. ! - subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -960,14 +957,13 @@ end subroutine read_diag_file_sst_nc !--------------------------------------------------------- ! netcdf read routine for t data types in netcdf files ! - subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) - - !--- interface - character(100), intent(in) :: input_file + subroutine read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) + + !--- interface logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1009,11 +1005,9 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp print *, ' ' print *, ' --> read_diag_file_t_nc' - print *, ' input_file = ', input_file print *, ' ftin = ', ftin print *, ' ctype = ', ctype print *, ' intype = ', intype - print *, ' expected_nreal = ', expected_nreal print *, ' in_subtype = ', in_subtype @@ -1197,14 +1191,13 @@ end subroutine read_diag_file_t_nc !--------------------------------------------------------- ! netcdf read routine for uv data types in netcdf files ! - subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1427,14 +1420,13 @@ end subroutine read_diag_file_uv_nc ! in binary and NetCDF formatted diag files. See ! comments below. ! - subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1454,14 +1446,14 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex real(r_single), dimension(:), allocatable :: Latitude ! (obs) real(r_single), dimension(:), allocatable :: Longitude ! (obs) real(r_single), dimension(:), allocatable :: Incremental_Bending_Angle ! (obs) - real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) + !real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Pressure ! (obs) real(r_single), dimension(:), allocatable :: Height ! (obs) real(r_single), dimension(:), allocatable :: Time ! (obs) real(r_single), dimension(:), allocatable :: Model_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Setup_QC_Mark ! (obs) real(r_single), dimension(:), allocatable :: Prep_Use_Flag ! (obs) - real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) + !real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) real(r_single), dimension(:), allocatable :: Nonlinear_QC_Rel_Wgt ! (obs) real(r_single), dimension(:), allocatable :: Analysis_Use_Flag ! (obs) real(r_single), dimension(:), allocatable :: Errinv_Input ! (obs) diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/grads_sfc.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/grads_sfc.f90 index 0f28e907..0845ddf9 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/grads_sfc.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/grads_sfc.f90 @@ -5,7 +5,7 @@ ! horizontal GrADS data files. !------------------------------------------------------------------------ -subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,isubtype,subtype,list,run) +subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,subtype,list,run) use generic_list use data @@ -28,7 +28,6 @@ subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,isubtype,subtype,lis integer nobs,nreal,nflg0,nlev0,iscater,igrads real(4) rtim,xlat0,xlon0,rlat,rlon - integer(4):: isubtype integer i,j,ilat,ilon,ipres,itime,iweight,ndup rtim=0.0 diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/maingrads_sfc.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/maingrads_sfc.f90 index e417893b..6ab6edb3 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/maingrads_sfc.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfc.fd/maingrads_sfc.f90 @@ -16,12 +16,12 @@ program maingrads_sfc interface subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,& - isubtype, subtype, list, run) + subtype, list, run) use generic_list integer ifileo character(ifileo) :: fileo - integer :: nobs,nreal,iscater,igrads,isubtype + integer :: nobs,nreal,iscater,igrads character(3) :: subtype type(list_node_t), pointer :: list character(3) :: run @@ -57,7 +57,7 @@ end subroutine grads_sfc if( nobs > 0 ) then - call grads_sfc(stype,lstype,nobs,nreal,iscater,igrads,isubtype,subtype,list,run) + call grads_sfc(stype,lstype,nobs,nreal,iscater,igrads,subtype,list,run) else print *, 'NOBS <= 0, NO OUTPUT GENERATED' end if diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/conmon_read_diag.F90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/conmon_read_diag.F90 index 2ceaffd7..e98b6ad0 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/conmon_read_diag.F90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/conmon_read_diag.F90 @@ -159,7 +159,7 @@ subroutine conmon_read_diag_file( input_file, ctype, intype, expected_nreal, nob if ( netcdf ) then write(6,*) ' call nc read subroutine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) end if @@ -205,7 +205,7 @@ subroutine conmon_return_all_obs( input_file, ctype, nobs, list ) ! if ( netcdf ) then write(6,*) ' call nc retrieve all routine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else write(6,*) ' call bin retrieve all routine' call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) @@ -221,13 +221,13 @@ end subroutine conmon_return_all_obs ! ! NetCDF read routine !------------------------------- - subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) !--- interface character(100), intent(in) :: input_file logical, intent(in) :: return_all character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -267,22 +267,22 @@ subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nr select case ( trim( adjustl( ctype ) ) ) case ( 'gps' ) - call read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'ps' ) - call read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'q' ) - call read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'sst' ) - call read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 't' ) - call read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'uv' ) - call read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case default print *, 'ERROR: unmatched ctype :', ctype @@ -315,14 +315,13 @@ end subroutine read_diag_file_nc !--------------------------------------------------------- ! netcdf read routine for ps data types in netcdf files ! - subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -517,14 +516,13 @@ end subroutine read_diag_file_ps_nc !--------------------------------------------------------- ! netcdf read routine for q data types in netcdf files ! - subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -731,14 +729,13 @@ end subroutine read_diag_file_q_nc ! NOTE2: There are known discrepencies between the contents ! of sst obs in binary and NetCDF files. ! - subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -960,14 +957,13 @@ end subroutine read_diag_file_sst_nc !--------------------------------------------------------- ! netcdf read routine for t data types in netcdf files ! - subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1009,11 +1005,9 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp print *, ' ' print *, ' --> read_diag_file_t_nc' - print *, ' input_file = ', input_file print *, ' ftin = ', ftin print *, ' ctype = ', ctype print *, ' intype = ', intype - print *, ' expected_nreal = ', expected_nreal print *, ' in_subtype = ', in_subtype @@ -1197,14 +1191,13 @@ end subroutine read_diag_file_t_nc !--------------------------------------------------------- ! netcdf read routine for uv data types in netcdf files ! - subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1427,14 +1420,13 @@ end subroutine read_diag_file_uv_nc ! in binary and NetCDF formatted diag files. See ! comments below. ! - subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -1454,14 +1446,14 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex real(r_single), dimension(:), allocatable :: Latitude ! (obs) real(r_single), dimension(:), allocatable :: Longitude ! (obs) real(r_single), dimension(:), allocatable :: Incremental_Bending_Angle ! (obs) - real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) + !real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Pressure ! (obs) real(r_single), dimension(:), allocatable :: Height ! (obs) real(r_single), dimension(:), allocatable :: Time ! (obs) real(r_single), dimension(:), allocatable :: Model_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Setup_QC_Mark ! (obs) real(r_single), dimension(:), allocatable :: Prep_Use_Flag ! (obs) - real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) + !real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) real(r_single), dimension(:), allocatable :: Nonlinear_QC_Rel_Wgt ! (obs) real(r_single), dimension(:), allocatable :: Analysis_Use_Flag ! (obs) real(r_single), dimension(:), allocatable :: Errinv_Input ! (obs) @@ -1689,7 +1681,6 @@ subroutine read_diag_file_bin( input_file, return_all, ctype, intype,expected_nr character(8),allocatable,dimension(:) :: cdiag character(3) :: dtype - character(10) :: otype integer nchar,file_nreal,i,ii,mype,idate,iflag,file_itype integer lunin,file_subtype diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/grads_sfctime.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/grads_sfctime.f90 index 57621b18..ffa62320 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/grads_sfctime.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/grads_sfctime.f90 @@ -7,7 +7,7 @@ !--------------------------------------------------------------------------------- subroutine grads_sfctime(fileo,ifileo,nobs,nreal,nlev,plev,iscater,& - igrads,isubtype,subtype,list,run) + igrads,subtype,list,run) use generic_list use data @@ -15,6 +15,7 @@ subroutine grads_sfctime(fileo,ifileo,nobs,nreal,nlev,plev,iscater,& implicit none external :: rm_dups + external :: getlev type(list_node_t), pointer :: list type(list_node_t), pointer :: next => null() @@ -22,7 +23,6 @@ subroutine grads_sfctime(fileo,ifileo,nobs,nreal,nlev,plev,iscater,& integer, intent(in) :: ifileo, nobs, nreal, nlev integer, intent(in) :: iscater, igrads - integer(4), intent(in) :: isubtype character(ifileo),intent(in) :: fileo character(3), intent(in) :: run, subtype diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/maingrads_sfctime.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/maingrads_sfctime.f90 index e08ee0e5..e812b9e4 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/maingrads_sfctime.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sfctime.fd/maingrads_sfctime.f90 @@ -17,13 +17,13 @@ program maingrads_sfctime interface subroutine grads_sfctime(fileo,ifileo,nobs,nreal,& - nlev,plev,iscater,igrads,isubtype,subtype,list,run) + nlev,plev,iscater,igrads,subtype,list,run) use generic_list integer :: ifileo,nobs,nreal,nlev character(ifileo) :: fileo real(4),dimension(nlev) :: plev - integer :: iscater,igrads,isubtype + integer :: iscater,igrads character(3) :: subtype type(list_node_t),pointer :: list character(3) :: run @@ -71,10 +71,10 @@ end subroutine grads_sfctime if( trim(timecard) == 'time11') then call grads_sfctime(stype,lstype,nobs,nreal,n_time11,& - ptime11,iscater,igrads,isubtype,subtype, list, run) + ptime11,iscater,igrads,subtype, list, run) else if( trim(timecard) == 'time7') then call grads_sfctime(stype,lstype,nobs,nreal,n_time7,& - ptime7,iscater,igrads,isubtype,subtype,list, run) + ptime7,iscater,igrads,subtype,list, run) endif else diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sig.fd/grads_sig.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sig.fd/grads_sig.f90 index 97274336..73a882bd 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sig.fd/grads_sig.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_grads_sig.fd/grads_sig.f90 @@ -13,6 +13,7 @@ subroutine grads_sig(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,isubtype,s implicit none external :: rm_dups + external :: getpro type(list_node_t), pointer :: list type(list_node_t), pointer :: next => null() diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/conmon_read_diag.F90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/conmon_read_diag.F90 index 5cc5f50b..75defec1 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/conmon_read_diag.F90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/conmon_read_diag.F90 @@ -161,7 +161,7 @@ subroutine conmon_read_diag_file( input_file, ctype, intype, expected_nreal, nob if ( netcdf ) then write(6,*) ' call nc read subroutine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) end if @@ -207,7 +207,7 @@ subroutine conmon_return_all_obs( input_file, ctype, nobs, list ) ! if ( netcdf ) then write(6,*) ' call nc retrieve all routine' - call read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) else write(6,*) ' call bin retrieve all routine' call read_diag_file_bin( input_file,return_all, ctype, intype, expected_nreal,nobs,in_subtype, list ) @@ -223,13 +223,13 @@ end subroutine conmon_return_all_obs ! ! NetCDF read routine !------------------------------- - subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_nc( input_file, return_all, ctype, intype, nobs, in_subtype, list ) !--- interface character(100), intent(in) :: input_file logical, intent(in) :: return_all character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list @@ -269,22 +269,22 @@ subroutine read_diag_file_nc( input_file, return_all, ctype, intype, expected_nr select case ( trim( adjustl( ctype ) ) ) case ( 'gps' ) - call read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'ps' ) - call read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'q' ) - call read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'sst' ) - call read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 't' ) - call read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case ( 'uv' ) - call read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + call read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) case default print *, 'ERROR: unmatched ctype :', ctype @@ -317,21 +317,20 @@ end subroutine read_diag_file_nc !--------------------------------------------------------- ! netcdf read routine for ps data types in netcdf files ! - subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_ps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -367,7 +366,8 @@ subroutine read_diag_file_ps_nc( input_file, return_all, ftin, ctype, intype,exp ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -519,21 +519,20 @@ end subroutine read_diag_file_ps_nc !--------------------------------------------------------- ! netcdf read routine for q data types in netcdf files ! - subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_q_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -570,7 +569,8 @@ subroutine read_diag_file_q_nc( input_file, return_all, ftin, ctype, intype,expe ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -733,21 +733,20 @@ end subroutine read_diag_file_q_nc ! NOTE2: There are known discrepencies between the contents ! of sst obs in binary and NetCDF files. ! - subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_sst_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -787,7 +786,8 @@ subroutine read_diag_file_sst_nc( input_file, return_all, ftin, ctype, intype,ex ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -962,21 +962,20 @@ end subroutine read_diag_file_sst_nc !--------------------------------------------------------- ! netcdf read routine for t data types in netcdf files ! - subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_t_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx, bcor_terms + integer :: ii, ierr, total_obs, idx, bcor_terms, id logical :: have_subtype = .true. logical :: add_obs @@ -1011,11 +1010,9 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp print *, ' ' print *, ' --> read_diag_file_t_nc' - print *, ' input_file = ', input_file print *, ' ftin = ', ftin print *, ' ctype = ', ctype print *, ' intype = ', intype - print *, ' expected_nreal = ', expected_nreal print *, ' in_subtype = ', in_subtype @@ -1023,7 +1020,8 @@ subroutine read_diag_file_t_nc( input_file, return_all, ftin, ctype, intype, exp ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs else print *, 'ERROR: unable to read nobs' ierr=1 @@ -1199,21 +1197,20 @@ end subroutine read_diag_file_t_nc !--------------------------------------------------------- ! netcdf read routine for uv data types in netcdf files ! - subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, expected_nreal, nobs, in_subtype, list ) + subroutine read_diag_file_uv_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -1254,7 +1251,8 @@ subroutine read_diag_file_uv_nc( input_file, return_all, ftin, ctype, intype, ex ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' @@ -1429,21 +1427,20 @@ end subroutine read_diag_file_uv_nc ! in binary and NetCDF formatted diag files. See ! comments below. ! - subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,expected_nreal,nobs,in_subtype, list ) + subroutine read_diag_file_gps_nc( return_all, ftin, ctype, intype, nobs, in_subtype, list ) !--- interface - character(100), intent(in) :: input_file logical, intent(in) :: return_all integer, intent(in) :: ftin character(3), intent(in) :: ctype - integer, intent(in) :: intype, expected_nreal, in_subtype + integer, intent(in) :: intype, in_subtype integer, intent(out) :: nobs type(list_node_t), pointer :: list !--- local vars type(list_node_t), pointer :: next => null() type(data_ptr) :: ptr - integer :: ii, ierr, total_obs, idx + integer :: ii, ierr, total_obs, idx, id logical :: have_subtype = .true. logical :: add_obs @@ -1456,14 +1453,14 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex real(r_single), dimension(:), allocatable :: Latitude ! (obs) real(r_single), dimension(:), allocatable :: Longitude ! (obs) real(r_single), dimension(:), allocatable :: Incremental_Bending_Angle ! (obs) - real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) + !real(r_single), dimension(:), allocatable :: Station_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Pressure ! (obs) real(r_single), dimension(:), allocatable :: Height ! (obs) real(r_single), dimension(:), allocatable :: Time ! (obs) real(r_single), dimension(:), allocatable :: Model_Elevation ! (obs) real(r_single), dimension(:), allocatable :: Setup_QC_Mark ! (obs) real(r_single), dimension(:), allocatable :: Prep_Use_Flag ! (obs) - real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) + !real(r_single), dimension(:), allocatable :: Nonlinear_QC_Var_Jb ! (obs) real(r_single), dimension(:), allocatable :: Nonlinear_QC_Rel_Wgt ! (obs) real(r_single), dimension(:), allocatable :: Analysis_Use_Flag ! (obs) real(r_single), dimension(:), allocatable :: Errinv_Input ! (obs) @@ -1485,7 +1482,8 @@ subroutine read_diag_file_gps_nc( input_file, return_all, ftin, ctype, intype,ex ! if( nc_diag_read_check_dim( 'nobs' )) then total_obs = nc_diag_read_get_dim(ftin,'nobs') - ncdiag_open_status(ii)%num_records = total_obs + id = find_ncdiag_id(ftin) + ncdiag_open_status(id)%num_records = total_obs print *, ' total_obs = ', total_obs else print *, 'ERROR: unable to read nobs' diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/mainconv_time.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/mainconv_time.f90 index ee7290bb..a031b047 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/mainconv_time.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/mainconv_time.f90 @@ -108,16 +108,16 @@ iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv, iosubtype_gps) - call creatstas_ctl(dtype_ps,iotype_ps,ituse_ps,100,ntype_ps,1,nregion,18,region,& + call creatstas_ctl(dtype_ps,iotype_ps,ituse_ps,ntype_ps,1,nregion,18,region,& rlatmin,rlatmax,rlonmin,rlonmax,iosubtype_ps) - call creatstas_ctl(dtype_q,iotype_q,ituse_q,100,ntype_q,np,nregion,18,region,& + call creatstas_ctl(dtype_q,iotype_q,ituse_q,ntype_q,np,nregion,18,region,& rlatmin,rlatmax,rlonmin,rlonmax,iosubtype_q) - call creatstas_ctl(dtype_t,iotype_t,ituse_t,100,ntype_t,np,nregion,18,& + call creatstas_ctl(dtype_t,iotype_t,ituse_t,ntype_t,np,nregion,18,& region,rlatmin,rlatmax,rlonmin,rlonmax,iosubtype_t) - call creatstas_ctl(dtype_uv,iotype_uv,ituse_uv,100,ntype_uv,np,nregion,18,& + call creatstas_ctl(dtype_uv,iotype_uv,ituse_uv,ntype_uv,np,nregion,18,& region,rlatmin,rlatmax,rlonmin,rlonmax,iosubtype_uv) - call creatstas_ctl(dtype_gps,iotype_gps,ituse_gps,100,ntype_gps,np,nregion,18,region,& + call creatstas_ctl(dtype_gps,iotype_gps,ituse_gps,ntype_gps,np,nregion,18,region,& rlatmin,rlatmax,rlonmin,rlonmax,iosubtype_gps) stop diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/process_time_data.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/process_time_data.f90 index 71eacc83..95aaaf7a 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/process_time_data.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/process_time_data.f90 @@ -39,13 +39,25 @@ module conmon_process_time_data use ncdr_vars, only: nc_diag_read_check_var use conmon_read_diag - + use stas_time_mod, only: stascal !--- implicit ---! implicit none - external :: stascal - external :: stascal_gps + interface + subroutine stascal_gps(rdiag,nreal,n,iotype,varqc,ntype,work,& + np,htop,hbot,nregion,mregion,& + rlatmin,rlatmax,rlonmin,rlonmax,iosubtype) + implicit none + integer :: nreal,n,ntype,np,nregion,mregion + real(4),dimension(nreal,n) :: rdiag + integer,dimension(:) :: iotype,iosubtype + real(4),dimension(:,:) :: varqc + real(4),dimension(:,:,:,:,:) :: work + real(4),dimension(np) :: htop,hbot + real(4),dimension(mregion):: rlatmin,rlatmax,rlonmin,rlonmax + end subroutine stascal_gps + end interface !--- public & private ---! private @@ -96,23 +108,50 @@ subroutine process_conv_diag(input_file,ctype,mregion,nregion,np, & integer mregion,nregion,np real(4),dimension(np) :: ptop,pbot,ptopq,pbotq,htop_gps,hbot_gps real,dimension(mregion) :: rlatmin,rlatmax,rlonmin,rlonmax - integer,dimension(100) :: iotype_ps,iotype_q,iotype_t,iotype_uv,iotype_gps - real(4),dimension(100,2) :: varqc_ps,varqc_q,varqc_t,varqc_uv,varqc_gps + integer,dimension(:) :: iotype_ps,iotype_q,iotype_t,iotype_uv,iotype_gps + real(4),dimension(:,:) :: varqc_ps,varqc_q,varqc_t,varqc_uv,varqc_gps integer ntype_ps,ntype_q,ntype_t,ntype_uv,ntype_gps - integer,dimension(100) :: iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv, iosubtype_gps + integer,dimension(:) :: iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv, iosubtype_gps + integer ntype_ps_use,ntype_q_use,ntype_t_use,ntype_uv_use,ntype_gps_use + integer ntype_ps_dim,ntype_q_dim,ntype_t_dim,ntype_uv_dim,ntype_gps_dim + + real(4),allocatable,dimension(:,:,:,:,:) :: twork,qwork,uwork,vwork,uvwork + real(4),allocatable,dimension(:,:,:,:,:) :: pswork + + ! Arrays are dimensioned to 100 in the type slot and use ntype+1 for totals, + ! so the maximum safe number of concrete types is 99. + ntype_ps_use = max( 0, min( ntype_ps, min(size(iotype_ps), min(size(iosubtype_ps), size(varqc_ps,1))) )) + ntype_q_use = max( 0, min( ntype_q, min(size(iotype_q), min(size(iosubtype_q), size(varqc_q,1))) )) + ntype_t_use = max( 0, min( ntype_t, min(size(iotype_t), min(size(iosubtype_t), size(varqc_t,1))) )) + ntype_uv_use = max( 0, min( ntype_uv, min(size(iotype_uv), min(size(iosubtype_uv), size(varqc_uv,1))) )) + ntype_gps_use = max( 0, min( ntype_gps, min(size(iotype_gps),min(size(iosubtype_gps),size(varqc_gps,1))) )) + + ntype_ps_dim = max( 1, ntype_ps_use + 1 ) + ntype_q_dim = max( 1, ntype_q_use + 1 ) + ntype_t_dim = max( 1, ntype_t_use + 1 ) + ntype_uv_dim = max( 1, ntype_uv_use + 1 ) + ntype_gps_dim = max( 1, ntype_gps_use+ 1 ) + + if( ntype_ps_use /= ntype_ps .or. ntype_q_use /= ntype_q .or. ntype_t_use /= ntype_t .or. & + ntype_uv_use /= ntype_uv .or. ntype_gps_use /= ntype_gps ) then + write(6,*) 'WARNING: ntype exceeds available metadata array sizes; truncating where needed.' + write(6,*) 'ntype_ps, ntype_q, ntype_t, ntype_uv, ntype_gps = ', & + ntype_ps_use, ntype_q_use, ntype_t_use, ntype_uv_use, ntype_gps_use + end if - real(4),dimension(np,100,6,nregion,3) :: twork,qwork,uwork,vwork,uvwork - real(4),dimension(1,100,6,nregion,3) :: pswork + allocate( twork(np,ntype_t_dim,6,nregion,3), qwork(np,ntype_q_dim,6,nregion,3), & + uwork(np,ntype_uv_dim,6,nregion,3), vwork(np,ntype_uv_dim,6,nregion,3), & + uvwork(np,ntype_uv_dim,6,nregion,3), pswork(1,ntype_ps_dim,6,nregion,3) ) write(6,*) 'input_file = ', input_file if( netcdf ) then write(6,*) ' call nc read subroutine' - call process_conv_nc( input_file, ctype, mregion,nregion,np,ptop,pbot,ptopq,pbotq,& + call process_conv_nc( input_file, ctype, mregion,nregion,np,ptop,pbot,& htop_gps, hbot_gps,& rlatmin,rlatmax,rlonmin,rlonmax,iotype_ps,iotype_q,& iotype_t,iotype_uv,iotype_gps,varqc_ps,varqc_q,varqc_t,varqc_uv,varqc_gps,& - ntype_ps,ntype_q,ntype_t,ntype_uv,ntype_gps,& + ntype_ps_use,ntype_q_use,ntype_t_use,ntype_uv_use,ntype_gps_use,& iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv,iosubtype_gps,& twork,uwork,vwork,uvwork ) else @@ -120,14 +159,21 @@ subroutine process_conv_diag(input_file,ctype,mregion,nregion,np, & call process_conv_bin( input_file,mregion,nregion,np,ptop,pbot,ptopq,pbotq,& rlatmin,rlatmax,rlonmin,rlonmax,iotype_ps,iotype_q,& iotype_t,iotype_uv,varqc_ps,varqc_q,varqc_t,varqc_uv,& - ntype_ps,ntype_q,ntype_t,ntype_uv,& + ntype_ps_use,ntype_q_use,ntype_t_use,ntype_uv_use,& iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv, & twork,qwork,uwork,vwork,uvwork, pswork ) call output_data( twork, qwork, uwork, vwork, uvwork, pswork, & - ntype_ps, ntype_q, ntype_t, ntype_uv, nregion, np ) + ntype_ps_use, ntype_q_use, ntype_t_use, ntype_uv_use, nregion, np ) end if + if( allocated(twork) ) deallocate(twork) + if( allocated(qwork) ) deallocate(qwork) + if( allocated(uwork) ) deallocate(uwork) + if( allocated(vwork) ) deallocate(vwork) + if( allocated(uvwork) ) deallocate(uvwork) + if( allocated(pswork) ) deallocate(pswork) + end subroutine process_conv_diag @@ -155,13 +201,13 @@ subroutine process_conv_bin(input_file,mregion,nregion,np,ptop,pbot,ptopq,pbotq, integer, intent(in) :: np real(4),dimension(np),intent(in) :: ptop,pbot,ptopq,pbotq real,dimension(mregion),intent(in) :: rlatmin,rlatmax,rlonmin,rlonmax - integer,dimension(100),intent(in) :: iotype_ps,iotype_q,iotype_t,iotype_uv - real(4),dimension(100,2),intent(in) :: varqc_ps,varqc_q,varqc_t,varqc_uv + integer,dimension(:),intent(in) :: iotype_ps,iotype_q,iotype_t,iotype_uv + real(4),dimension(:,:),intent(in) :: varqc_ps,varqc_q,varqc_t,varqc_uv integer, intent(in) :: ntype_ps,ntype_q,ntype_t - integer,dimension(100),intent(in) :: iosubtype_ps,iosubtype_q,iosubtype_uv,iosubtype_t + integer,dimension(:),intent(in) :: iosubtype_ps,iosubtype_q,iosubtype_uv,iosubtype_t - real(4),dimension(np,100,6,nregion,3), intent(out) :: twork,qwork,uwork,vwork,uvwork - real(4),dimension(1,100,6,nregion,3), intent(out) :: pswork + real(4),dimension(:,:,:,:,:), intent(out) :: twork,qwork,uwork,vwork,uvwork + real(4),dimension(:,:,:,:,:), intent(out) :: pswork @@ -249,7 +295,7 @@ end subroutine process_conv_bin ! tar file contains 4 ges and 4 anl diag files. !----------------------------------------------------------- subroutine process_conv_nc( input_file, ctype, mregion, nregion, np, & - ptop, pbot, ptopq, pbotq, htop_gps, hbot_gps, rlatmin, rlatmax, rlonmin, rlonmax, & + ptop, pbot, htop_gps, hbot_gps, rlatmin, rlatmax, rlonmin, rlonmax, & iotype_ps, iotype_q, iotype_t, iotype_uv, iotype_gps, varqc_ps, varqc_q, & varqc_t, varqc_uv, varqc_gps, ntype_ps, ntype_q, ntype_t, ntype_uv, ntype_gps,& iosubtype_ps, iosubtype_q, iosubtype_t, iosubtype_uv, iosubtype_gps,& @@ -266,21 +312,21 @@ subroutine process_conv_nc( input_file, ctype, mregion, nregion, np, & integer, intent(in) :: mregion integer, intent(in) :: nregion integer, intent(in) :: np - real(4),dimension(np),intent(in) :: ptop,pbot,ptopq,pbotq,htop_gps,hbot_gps + real(4),dimension(np),intent(in) :: ptop,pbot,htop_gps,hbot_gps real,dimension(mregion),intent(in) :: rlatmin,rlatmax,rlonmin,rlonmax - integer,dimension(100),intent(in) :: iotype_ps,iotype_q,iotype_t,iotype_uv,iotype_gps - real(4),dimension(100,2),intent(in) :: varqc_ps,varqc_q,varqc_t,varqc_uv,varqc_gps + integer,dimension(:),intent(in) :: iotype_ps,iotype_q,iotype_t,iotype_uv,iotype_gps + real(4),dimension(:,:),intent(in) :: varqc_ps,varqc_q,varqc_t,varqc_uv,varqc_gps integer, intent(in) :: ntype_uv,ntype_ps,ntype_q,ntype_t,ntype_gps - integer,dimension(100),intent(in) :: iosubtype_ps,iosubtype_q,iosubtype_uv,iosubtype_t,iosubtype_gps + integer,dimension(:),intent(in) :: iosubtype_ps,iosubtype_q,iosubtype_uv,iosubtype_t,iosubtype_gps !======================================================================== ! NOTE: I think the *work arrays don't need to be params -- they are ! just used here and can then be deallocated w/o issue. !======================================================================== - real(4),dimension(np,100,6,nregion,3), intent(out) :: twork,uwork,vwork,uvwork - real(4),dimension(np,100,6,nregion,3) :: qwork, gpswork - real(4),dimension(1,100,6,nregion,3) :: pswork + real(4),dimension(:,:,:,:,:), intent(out) :: twork,uwork,vwork + real(4),dimension(:,:,:,:,:), intent(out) :: uvwork + real(4),allocatable,dimension(:,:,:,:,:) :: qwork, gpswork, pswork type(list_node_t), pointer :: list => null() @@ -297,6 +343,9 @@ subroutine process_conv_nc( input_file, ctype, mregion, nregion, np, & print *, ' input_file = ', input_file print *, ' ctype = ', ctype + allocate( qwork(np,max(1,ntype_q+1),6,nregion,3), gpswork(np,max(1,ntype_gps+1),6,nregion,3), & + pswork(1,max(1,ntype_ps+1),6,nregion,3) ) + twork=0.0; qwork=0.0; uwork=0.0; vwork=0.0; uvwork=0.0; pswork=0.0; gpswork=0.0 call conmon_return_all_obs( input_file, ctype, nobs, list ) @@ -334,7 +383,7 @@ subroutine process_conv_nc( input_file, ctype, mregion, nregion, np, & print *, 'found nobs in list = ', obs_ctr - call output_data_ps( pswork, ntype_ps, nregion, 1 ) + call output_data_ps( pswork, ntype_ps, nregion ) case ( 'q' ) print *, ' select, case q' @@ -426,7 +475,7 @@ subroutine process_conv_nc( input_file, ctype, mregion, nregion, np, & print *, 'found nobs in list = ', obs_ctr call list_free( list ) - call stascal_gps(ctype, rdiag, max_rdiag_reals, nobs, iotype_gps, varqc_gps, ntype_gps, & + call stascal_gps(rdiag, max_rdiag_reals, nobs, iotype_gps, varqc_gps, ntype_gps, & gpswork, np, htop_gps, hbot_gps, nregion, mregion, & rlatmin, rlatmax, rlonmin, rlonmax, iosubtype_gps) @@ -436,6 +485,9 @@ subroutine process_conv_nc( input_file, ctype, mregion, nregion, np, & if( allocated( rdiag )) deallocate( rdiag ) + if( allocated( qwork )) deallocate( qwork ) + if( allocated( gpswork )) deallocate( gpswork ) + if( allocated( pswork )) deallocate( pswork ) print *, '<-- process_conv_nc' @@ -443,10 +495,10 @@ end subroutine process_conv_nc - subroutine output_data_ps( pswork, ntype_ps, nregion, np ) + subroutine output_data_ps( pswork, ntype_ps, nregion ) - real(4),dimension(1,100,6,nregion,3), intent(inout) :: pswork - integer, intent(in) :: ntype_ps, nregion, np + real(4),dimension(:,:,:,:,:), intent(inout) :: pswork + integer, intent(in) :: ntype_ps, nregion integer :: ii, jj, ltype, iregion integer, parameter :: outfile = 21 @@ -476,7 +528,7 @@ subroutine output_data_ps( pswork, ntype_ps, nregion, np ) pswork(1,ltype,3,iregion,jj)= & pswork(1,ltype,3,iregion,jj)/pswork(1,ltype,1,iregion,jj) pswork(1,ltype,4,iregion,jj)= & - sqrt(pswork(1,ltype,4,iregion,jj)/pswork(1,ltype,1,iregion,jj)) + sqrt(max(0.0, pswork(1,ltype,4,iregion,jj))/pswork(1,ltype,1,iregion,jj)) pswork(1,ltype,5,iregion,jj)= & pswork(1,ltype,5,iregion,jj)/pswork(1,ltype,1,iregion,jj) pswork(1,ltype,6,iregion,jj)= & @@ -490,7 +542,7 @@ subroutine output_data_ps( pswork, ntype_ps, nregion, np ) if(pswork(1,ntype_ps+1,1,iregion,jj) >=1.0) then pswork(1,ntype_ps+1,3,iregion,jj) = pswork(1,ntype_ps+1,3,iregion,jj)/& pswork(1,ntype_ps+1,1,iregion,jj) - pswork(1,ntype_ps+1,4,iregion,jj) = sqrt(pswork(1,ntype_ps+1,4,iregion,jj)& + pswork(1,ntype_ps+1,4,iregion,jj) = sqrt(max(0.0, pswork(1,ntype_ps+1,4,iregion,jj))& /pswork(1,ntype_ps+1,1,iregion,jj)) pswork(1,ntype_ps+1,5,iregion,jj) = pswork(1,ntype_ps+1,5,iregion,jj)/& pswork(1,ntype_ps+1,1,iregion,jj) @@ -518,7 +570,7 @@ end subroutine output_data_ps subroutine output_data_q( qwork, ntype_q, nregion, np ) - real(4),dimension(np,100,6,nregion,3), intent(inout) :: qwork + real(4),dimension(:,:,:,:,:), intent(inout) :: qwork integer, intent(in) :: ntype_q, nregion, np integer :: ii, jj, kk, ltype, iregion @@ -546,7 +598,7 @@ subroutine output_data_q( qwork, ntype_q, nregion, np ) qwork(kk,ltype,3,iregion,jj) = & qwork(kk,ltype,3,iregion,jj)/qwork(kk,ltype,1,iregion,jj) qwork(kk,ltype,4,iregion,jj) = & - sqrt(qwork(kk,ltype,4,iregion,jj)/qwork(kk,ltype,1,iregion,jj)) + sqrt(max(0.0, qwork(kk,ltype,4,iregion,jj))/qwork(kk,ltype,1,iregion,jj)) qwork(kk,ltype,5,iregion,jj) = & qwork(kk,ltype,5,iregion,jj)/qwork(kk,ltype,1,iregion,jj) qwork(kk,ltype,6,iregion,jj) = & @@ -557,7 +609,7 @@ subroutine output_data_q( qwork, ntype_q, nregion, np ) if(qwork(kk,ntype_q+1,1,iregion,jj) >=1.0) then qwork(kk,ntype_q+1,3,iregion,jj)=qwork(kk,ntype_q+1,3,iregion,jj)/& qwork(kk,ntype_q+1,1,iregion,jj) - qwork(kk,ntype_q+1,4,iregion,jj)=sqrt(qwork(kk,ntype_q+1,4,iregion,jj)/& + qwork(kk,ntype_q+1,4,iregion,jj)=sqrt(max(0.0,qwork(kk,ntype_q+1,4,iregion,jj))/& qwork(kk,ntype_q+1,1,iregion,jj)) qwork(kk,ntype_q+1,5,iregion,jj)=qwork(kk,ntype_q+1,5,iregion,jj)/& qwork(kk,ntype_q+1,1,iregion,jj) @@ -592,7 +644,7 @@ end subroutine output_data_q subroutine output_data_t( twork, ntype_t, nregion, np ) - real(4),dimension(np,100,6,nregion,3), intent(inout) :: twork + real(4),dimension(:,:,:,:,:), intent(inout) :: twork integer, intent(in) :: ntype_t, nregion, np integer :: ii, jj, kk, ltype, iregion @@ -621,7 +673,7 @@ subroutine output_data_t( twork, ntype_t, nregion, np ) twork(kk,ltype,3,iregion,jj) = & twork(kk,ltype,3,iregion,jj)/twork(kk,ltype,1,iregion,jj) twork(kk,ltype,4,iregion,jj) = & - sqrt(twork(kk,ltype,4,iregion,jj)/twork(kk,ltype,1,iregion,jj)) + sqrt(max(0.0, twork(kk,ltype,4,iregion,jj))/twork(kk,ltype,1,iregion,jj)) twork(kk,ltype,5,iregion,jj) = & twork(kk,ltype,5,iregion,jj)/twork(kk,ltype,1,iregion,jj) twork(kk,ltype,6,iregion,jj) = & @@ -632,7 +684,7 @@ subroutine output_data_t( twork, ntype_t, nregion, np ) if(twork(kk,ntype_t+1,1,iregion,jj) >=1.0) then twork(kk,ntype_t+1,3,iregion,jj) = twork(kk,ntype_t+1,3,iregion,jj)/& twork(kk,ntype_t+1,1,iregion,jj) - twork(kk,ntype_t+1,4,iregion,jj)=sqrt(twork(kk,ntype_t+1,4,iregion,jj)/& + twork(kk,ntype_t+1,4,iregion,jj)=sqrt(max(0.0, twork(kk,ntype_t+1,4,iregion,jj))/& twork(kk,ntype_t+1,1,iregion,jj)) twork(kk,ntype_t+1,5,iregion,jj)=twork(kk,ntype_t+1,5,iregion,jj)/& twork(kk,ntype_t+1,1,iregion,jj) @@ -666,7 +718,7 @@ end subroutine output_data_t subroutine output_data_uv( uvwork, uwork, vwork, ntype_uv, nregion, np ) - real(4),dimension(np,100,6,nregion,3), intent(inout) :: uvwork, uwork, vwork + real(4),dimension(:,:,:,:,:), intent(inout) :: uvwork, uwork, vwork integer, intent(in) :: ntype_uv, nregion, np integer :: ii, jj, kk, ltype, iregion @@ -703,7 +755,7 @@ subroutine output_data_uv( uvwork, uwork, vwork, ntype_uv, nregion, np ) uvwork(kk,ltype,3,iregion,jj) = & uvwork(kk,ltype,3,iregion,jj)/uvwork(kk,ltype,1,iregion,jj) uvwork(kk,ltype,4,iregion,jj) = & - sqrt(uvwork(kk,ltype,4,iregion,jj)/uvwork(kk,ltype,1,iregion,jj)) + sqrt(max(0.0, uvwork(kk,ltype,4,iregion,jj))/uvwork(kk,ltype,1,iregion,jj)) uvwork(kk,ltype,5,iregion,jj) = & uvwork(kk,ltype,5,iregion,jj)/uvwork(kk,ltype,1,iregion,jj) uvwork(kk,ltype,6,iregion,jj) = & @@ -715,18 +767,18 @@ subroutine output_data_uv( uvwork, uwork, vwork, ntype_uv, nregion, np ) uwork(kk,ltype,3,iregion,jj) = & uwork(kk,ltype,3,iregion,jj)/uvwork(kk,ltype,1,iregion,jj) uwork(kk,ltype,4,iregion,jj) = & - sqrt(uwork(kk,ltype,4,iregion,jj)/uvwork(kk,ltype,1,iregion,jj)) + sqrt(max(0.0, uwork(kk,ltype,4,iregion,jj))/uvwork(kk,ltype,1,iregion,jj)) vwork(kk,ltype,3,iregion,jj) = & vwork(kk,ltype,3,iregion,jj)/uvwork(kk,ltype,1,iregion,jj) vwork(kk,ltype,4,iregion,jj) = & - sqrt(vwork(kk,ltype,4,iregion,jj)/uvwork(kk,ltype,1,iregion,jj)) + sqrt(max(0.0, vwork(kk,ltype,4,iregion,jj))/uvwork(kk,ltype,1,iregion,jj)) endif enddo if(uvwork(kk,ntype_uv+1,1,iregion,jj) >=1.0) then uvwork(kk,ntype_uv+1,3,iregion,jj)=uvwork(kk,ntype_uv+1,3,iregion,jj)& /uvwork(kk,ntype_uv+1,1,iregion,jj) - uvwork(kk,ntype_uv+1,4,iregion,jj)=sqrt(uvwork(kk,ntype_uv+1,4,iregion,jj)& + uvwork(kk,ntype_uv+1,4,iregion,jj)=sqrt(max(0.0, uvwork(kk,ntype_uv+1,4,iregion,jj))& /uvwork(kk,ntype_uv+1,1,iregion,jj)) uvwork(kk,ntype_uv+1,5,iregion,jj)=uvwork(kk,ntype_uv+1,5,iregion,jj)& /uvwork(kk,ntype_uv+1,1,iregion,jj) @@ -739,11 +791,11 @@ subroutine output_data_uv( uvwork, uwork, vwork, ntype_uv, nregion, np ) uwork(kk,ntype_uv+1,3,iregion,jj)=uwork(kk,ntype_uv+1,3,iregion,jj)& /uwork(kk,ntype_uv+1,1,iregion,jj) - uwork(kk,ntype_uv+1,4,iregion,jj)=sqrt(uwork(kk,ntype_uv+1,4,iregion,jj)& + uwork(kk,ntype_uv+1,4,iregion,jj)=sqrt(max(0.0, uwork(kk,ntype_uv+1,4,iregion,jj))& /uwork(kk,ntype_uv+1,1,iregion,jj)) vwork(kk,ntype_uv+1,3,iregion,jj)=vwork(kk,ntype_uv+1,3,iregion,jj)& /vwork(kk,ntype_uv+1,1,iregion,jj) - vwork(kk,ntype_uv+1,4,iregion,jj)=sqrt(vwork(kk,ntype_uv+1,4,iregion,jj)& + vwork(kk,ntype_uv+1,4,iregion,jj)=sqrt(max(0.0, vwork(kk,ntype_uv+1,4,iregion,jj))& /vwork(kk,ntype_uv+1,1,iregion,jj)) endif @@ -788,9 +840,9 @@ end subroutine output_data_uv subroutine output_data_gps( gpswork, ntype_gps, nregion, np, iotype_gps ) - real(4),dimension(np,100,6,nregion,3), intent(inout) :: gpswork + real(4),dimension(:,:,:,:,:), intent(inout) :: gpswork integer, intent(in) :: ntype_gps, nregion, np - integer,dimension(100), intent(in) :: iotype_gps + integer,dimension(:), intent(in) :: iotype_gps integer :: ii, jj, kk, ltype, iregion integer, parameter :: outfile = 61 integer, parameter :: nobsfile = 62 @@ -820,7 +872,7 @@ subroutine output_data_gps( gpswork, ntype_gps, nregion, np, iotype_gps ) gpswork(kk,ltype,3,iregion,jj) = & gpswork(kk,ltype,3,iregion,jj)/gpswork(kk,ltype,1,iregion,jj) gpswork(kk,ltype,4,iregion,jj) = & - sqrt(gpswork(kk,ltype,4,iregion,jj)/gpswork(kk,ltype,1,iregion,jj)) + sqrt(max(0.0, gpswork(kk,ltype,4,iregion,jj))/gpswork(kk,ltype,1,iregion,jj)) gpswork(kk,ltype,5,iregion,jj) = & gpswork(kk,ltype,5,iregion,jj)/gpswork(kk,ltype,1,iregion,jj) gpswork(kk,ltype,6,iregion,jj) = & @@ -831,7 +883,7 @@ subroutine output_data_gps( gpswork, ntype_gps, nregion, np, iotype_gps ) if(gpswork(kk,ntype_gps+1,1,iregion,jj) >=1.0) then gpswork(kk,ntype_gps+1,3,iregion,jj)=gpswork(kk,ntype_gps+1,3,iregion,jj)/& gpswork(kk,ntype_gps+1,1,iregion,jj) - gpswork(kk,ntype_gps+1,4,iregion,jj)=sqrt(gpswork(kk,ntype_gps+1,4,iregion,jj)/& + gpswork(kk,ntype_gps+1,4,iregion,jj)=sqrt(max(0.0, gpswork(kk,ntype_gps+1,4,iregion,jj))/& gpswork(kk,ntype_gps+1,1,iregion,jj)) gpswork(kk,ntype_gps+1,5,iregion,jj)=gpswork(kk,ntype_gps+1,5,iregion,jj)/& gpswork(kk,ntype_gps+1,1,iregion,jj) @@ -892,8 +944,8 @@ end subroutine output_data_gps subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & ntype_ps, ntype_q, ntype_t, ntype_uv, nregion, np ) - real(4),dimension(np,100,6,nregion,3), intent(inout) :: twork,qwork,uwork,vwork,uvwork - real(4),dimension(1,100,6,nregion,3), intent(inout) :: pswork + real(4),dimension(:,:,:,:,:), intent(inout) :: twork,qwork,uwork,vwork,uvwork + real(4),dimension(:,:,:,:,:), intent(inout) :: pswork integer, intent(in) :: ntype_ps,ntype_q,ntype_t,ntype_uv,nregion,np integer :: i,j,k,ltype,iregion @@ -920,7 +972,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & pswork(1,ltype,3,iregion,j)= & pswork(1,ltype,3,iregion,j)/pswork(1,ltype,1,iregion,j) pswork(1,ltype,4,iregion,j)= & - sqrt(pswork(1,ltype,4,iregion,j)/pswork(1,ltype,1,iregion,j)) + sqrt(max(0.0, pswork(1,ltype,4,iregion,j))/pswork(1,ltype,1,iregion,j)) pswork(1,ltype,5,iregion,j)= & pswork(1,ltype,5,iregion,j)/pswork(1,ltype,1,iregion,j) pswork(1,ltype,6,iregion,j)= & @@ -934,7 +986,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & if(pswork(1,ntype_ps+1,1,iregion,j) >=1.0) then pswork(1,ntype_ps+1,3,iregion,j) = pswork(1,ntype_ps+1,3,iregion,j)/& pswork(1,ntype_ps+1,1,iregion,j) - pswork(1,ntype_ps+1,4,iregion,j) = sqrt(pswork(1,ntype_ps+1,4,iregion,j)& + pswork(1,ntype_ps+1,4,iregion,j) = sqrt(max(0.0, pswork(1,ntype_ps+1,4,iregion,j))& /pswork(1,ntype_ps+1,1,iregion,j)) pswork(1,ntype_ps+1,5,iregion,j) = pswork(1,ntype_ps+1,5,iregion,j)/& pswork(1,ntype_ps+1,1,iregion,j) @@ -961,7 +1013,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & qwork(k,ltype,3,iregion,j) = & qwork(k,ltype,3,iregion,j)/qwork(k,ltype,1,iregion,j) qwork(k,ltype,4,iregion,j) = & - sqrt(qwork(k,ltype,4,iregion,j)/qwork(k,ltype,1,iregion,j)) + sqrt(max(0.0, qwork(k,ltype,4,iregion,j))/qwork(k,ltype,1,iregion,j)) qwork(k,ltype,5,iregion,j) = & qwork(k,ltype,5,iregion,j)/qwork(k,ltype,1,iregion,j) qwork(k,ltype,6,iregion,j) = & @@ -972,7 +1024,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & if(qwork(k,ntype_q+1,1,iregion,j) >=1.0) then qwork(k,ntype_q+1,3,iregion,j)=qwork(k,ntype_q+1,3,iregion,j)/& qwork(k,ntype_q+1,1,iregion,j) - qwork(k,ntype_q+1,4,iregion,j)=sqrt(qwork(k,ntype_q+1,4,iregion,j)/& + qwork(k,ntype_q+1,4,iregion,j)=sqrt(max(0.0, qwork(k,ntype_q+1,4,iregion,j))/& qwork(k,ntype_q+1,1,iregion,j)) qwork(k,ntype_q+1,5,iregion,j)=qwork(k,ntype_q+1,5,iregion,j)/& qwork(k,ntype_q+1,1,iregion,j) @@ -998,7 +1050,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & twork(k,ltype,3,iregion,j) = & twork(k,ltype,3,iregion,j)/twork(k,ltype,1,iregion,j) twork(k,ltype,4,iregion,j) = & - sqrt(twork(k,ltype,4,iregion,j)/twork(k,ltype,1,iregion,j)) + sqrt(max(0.0, twork(k,ltype,4,iregion,j))/twork(k,ltype,1,iregion,j)) twork(k,ltype,5,iregion,j) = & twork(k,ltype,5,iregion,j)/twork(k,ltype,1,iregion,j) twork(k,ltype,6,iregion,j) = & @@ -1009,7 +1061,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & if(twork(k,ntype_t+1,1,iregion,j) >=1.0) then twork(k,ntype_t+1,3,iregion,j) = twork(k,ntype_t+1,3,iregion,j)/& twork(k,ntype_t+1,1,iregion,j) - twork(k,ntype_t+1,4,iregion,j)=sqrt(twork(k,ntype_t+1,4,iregion,j)/& + twork(k,ntype_t+1,4,iregion,j)=sqrt(max(0.0, twork(k,ntype_t+1,4,iregion,j))/& twork(k,ntype_t+1,1,iregion,j)) twork(k,ntype_t+1,5,iregion,j)=twork(k,ntype_t+1,5,iregion,j)/& twork(k,ntype_t+1,1,iregion,j) @@ -1043,7 +1095,7 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & uvwork(k,ltype,3,iregion,j) = & uvwork(k,ltype,3,iregion,j)/uvwork(k,ltype,1,iregion,j) uvwork(k,ltype,4,iregion,j) = & - sqrt(uvwork(k,ltype,4,iregion,j)/uvwork(k,ltype,1,iregion,j)) + sqrt(max(0.0, uvwork(k,ltype,4,iregion,j))/uvwork(k,ltype,1,iregion,j)) uvwork(k,ltype,5,iregion,j) = & uvwork(k,ltype,5,iregion,j)/uvwork(k,ltype,1,iregion,j) uvwork(k,ltype,6,iregion,j) = & @@ -1055,18 +1107,18 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & uwork(k,ltype,3,iregion,j) = & uwork(k,ltype,3,iregion,j)/uvwork(k,ltype,1,iregion,j) uwork(k,ltype,4,iregion,j) = & - sqrt(uwork(k,ltype,4,iregion,j)/uvwork(k,ltype,1,iregion,j)) + sqrt(max(0.0, uwork(k,ltype,4,iregion,j))/uvwork(k,ltype,1,iregion,j)) vwork(k,ltype,3,iregion,j) = & vwork(k,ltype,3,iregion,j)/uvwork(k,ltype,1,iregion,j) vwork(k,ltype,4,iregion,j) = & - sqrt(vwork(k,ltype,4,iregion,j)/uvwork(k,ltype,1,iregion,j)) + sqrt(max(0.0, vwork(k,ltype,4,iregion,j))/uvwork(k,ltype,1,iregion,j)) endif enddo if(uvwork(k,ntype_uv+1,1,iregion,j) >=1.0) then uvwork(k,ntype_uv+1,3,iregion,j)=uvwork(k,ntype_uv+1,3,iregion,j)& /uvwork(k,ntype_uv+1,1,iregion,j) - uvwork(k,ntype_uv+1,4,iregion,j)=sqrt(uvwork(k,ntype_uv+1,4,iregion,j)& + uvwork(k,ntype_uv+1,4,iregion,j)=sqrt(max(0.0, uvwork(k,ntype_uv+1,4,iregion,j))& /uvwork(k,ntype_uv+1,1,iregion,j)) uvwork(k,ntype_uv+1,5,iregion,j)=uvwork(k,ntype_uv+1,5,iregion,j)& /uvwork(k,ntype_uv+1,1,iregion,j) @@ -1079,11 +1131,11 @@ subroutine output_data( twork, qwork, uwork, vwork, uvwork, pswork, & uwork(k,ntype_uv+1,3,iregion,j)=uwork(k,ntype_uv+1,3,iregion,j)& /uwork(k,ntype_uv+1,1,iregion,j) - uwork(k,ntype_uv+1,4,iregion,j)=sqrt(uwork(k,ntype_uv+1,4,iregion,j)& + uwork(k,ntype_uv+1,4,iregion,j)=sqrt(max(0.0, uwork(k,ntype_uv+1,4,iregion,j))& /uwork(k,ntype_uv+1,1,iregion,j)) vwork(k,ntype_uv+1,3,iregion,j)=vwork(k,ntype_uv+1,3,iregion,j)& /vwork(k,ntype_uv+1,1,iregion,j) - vwork(k,ntype_uv+1,4,iregion,j)=sqrt(vwork(k,ntype_uv+1,4,iregion,j)& + vwork(k,ntype_uv+1,4,iregion,j)=sqrt(max(0.0, vwork(k,ntype_uv+1,4,iregion,j))& /vwork(k,ntype_uv+1,1,iregion,j)) endif diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas2ctl.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas2ctl.f90 index 9f7eb46b..838e4fb4 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas2ctl.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas2ctl.f90 @@ -4,12 +4,12 @@ ! Create the GrADS control file !========================================================== -subroutine creatstas_ctl(dtype,itype,ituse,nt,nc,nlev,nregion,nvar,& +subroutine creatstas_ctl(dtype,itype,ituse,nc,nlev,nregion,nvar,& region,rlatmin,rlatmax,rlonmin,rlonmax,isubtype) implicit none - integer nregion,nt,nlev,nc,i,icc,nvar - integer,dimension(nt):: itype,ituse,isubtype + integer nregion,nlev,nc,i,icc,nvar + integer,dimension(nc):: itype,ituse,isubtype character(7) dtype character(20) fileo character(40),dimension(nregion) :: region diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time.f90 index 2f6eaf36..21bed101 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time.f90 @@ -1,5 +1,13 @@ !! the subroutine is to calculate the statistics +module stas_time_mod + + implicit none + private + public :: stascal + +contains + subroutine stascal(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,worku,& workv,np,ptop,pbot,nregion,mregion,& rlatmin,rlatmax,rlonmin,rlonmax,iosubtype) @@ -7,18 +15,18 @@ subroutine stascal(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,worku,& implicit none real(4),dimension(nreal,n) :: rdiag - real(4),dimension(100,2) :: varqc - real(4),dimension(np,100,6,nregion,3) :: work,worku,workv + real(4),dimension(:,:) :: varqc + real(4),dimension(:,:,:,:,:) :: work,worku,workv real(4),dimension(np) :: ptop,pbot real(4),dimension(mregion):: rlatmin,rlatmax,rlonmin,rlonmax character(3) :: dtype - integer,dimension(100) :: iotype,iosubtype integer itype,isubtype,ilat,ilon,ipress,iqc,iuse,imuse integer iwgt,ierr1,ierr2,ierr3,iobg,iobgu,iobgv,iqsges integer iobsu,iobsv,i,nregion,mregion,np,n,nreal,k,j - integer ltype,ntype,intype,insubtype,nn + integer ltype,ntype,intype,insubtype,nn,ntype_eff + integer,dimension(:) :: iotype,iosubtype real cg_term,pi,tiny real valu,valv,val,val2,gesu,gesv,spdb,exp_arg,arg real ress,ressu,ressv,valqc,term,wgross,cg_t,wnotgross @@ -31,7 +39,8 @@ subroutine stascal(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,worku,& pi=acos(-1.0) cg_term=sqrt(2.0*pi)/2.0 tiny=1.0e-10 - + ntype_eff = min( ntype, size(iotype), size(iosubtype), size(varqc,1), & + size(work,2), size(worku,2), size(workv,2) ) do i=1,n if(trim(dtype) == ' uv') then @@ -63,7 +72,7 @@ subroutine stascal(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,worku,& endif ! print *,rdiag(itype,i),rdiag(ierr1,i),rdiag(ierr3,i),rdiag(imuse,i),nn - do ltype=1,ntype + do ltype=1,ntype_eff intype=int(rdiag(itype,i)) insubtype=int(rdiag(isubtype,i)) @@ -124,4 +133,6 @@ subroutine stascal(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,worku,& return -end +end subroutine stascal + +end module stas_time_mod diff --git a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time_gps.f90 b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time_gps.f90 index 09ae6c21..4f78ef2e 100644 --- a/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time_gps.f90 +++ b/src/Conventional_Monitor/nwprod/conmon_shared/sorc/conmon_time.fd/stas_time_gps.f90 @@ -1,24 +1,22 @@ !! the subroutine is to calculate the statistics for gps data -subroutine stascal_gps(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,& +subroutine stascal_gps(rdiag,nreal,n,iotype,varqc,ntype,work,& np,htop,hbot,nregion,mregion,& rlatmin,rlatmax,rlonmin,rlonmax,iosubtype) implicit none real(4),dimension(nreal,n) :: rdiag - real(4),dimension(100,2) :: varqc - real(4),dimension(np,100,6,nregion,3) :: work + real(4),dimension(:,:) :: varqc + real(4),dimension(:,:,:,:,:) :: work real(4),dimension(np) :: htop,hbot real(4),dimension(mregion):: rlatmin,rlatmax,rlonmin,rlonmax - - character(3) :: dtype - integer,dimension(100) :: iotype,iosubtype + integer,dimension(:) :: iotype,iosubtype integer itype,isubtype,ilat,ilon,iheight,iqc,iuse,imuse integer iwgt,ierr1,ierr2,ierr3,iobg,iobgu,iobgv,iqsges integer iobsu,iobsv,i,nregion,mregion,np,n,nreal,k,j - integer ltype,ntype,intype,insubtype,nn, test_height + integer ltype,ntype,intype,insubtype,nn, test_height, ntype_eff real cg_term,pi,tiny real val,val2,exp_arg,arg real ress,valqc,term,wgross,cg_t,wnotgross @@ -31,6 +29,7 @@ subroutine stascal_gps(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,& pi=acos(-1.0) cg_term=sqrt(2.0*pi)/2.0 tiny=1.0e-10 + ntype_eff = min( ntype, size(iotype), size(iosubtype), size(varqc,1), size(work,2) ) print *,'--> stascal_gps' @@ -53,7 +52,7 @@ subroutine stascal_gps(dtype,rdiag,nreal,n,iotype,varqc,ntype,work,& if(rdiag(ierr3,i) >tiny) nn=3 endif - do ltype=1,ntype + do ltype=1,ntype_eff intype=int(rdiag(itype,i)) insubtype=int(rdiag(isubtype,i))