!----------------------------------------------------------------------------! !Name: pack_outputs_mod ! !Type: F90 module ! !Function: ! This module contains the subroutines to pack the binary outputs ! of ET, 2, 4, 8, 12 WEEK ESI and QC flags to GRIB2 and NETCDF files ! !Description: ! The input should follow the same directory structure with other GETD ! output procedure. In the input directory, there will be time directory: ! Input/2015008 ! ET_day.bin ! ESI_2WEEK.BIN ! ESI_4WEEK.BIN ! ESI_8WEEK.BIN ! ESI_12WEEK.BIN ! EDAY.bin ! HDAY.bin ! GDAY.bin ! LWDNDAY.bin ! LWUPDAY.bin ! ! Output/2014008 ! GETD_ET.grib2 ! GETD_ET.nc ! !Files Needed: ! N/A ! !Modules Needed: ! - type_kinds ! - GETD_constants_mod ! - GETD_log_mod ! - grib_mod ! !Subroutines Contained: ! - pack_read_config ! - pack_init ! - pack_finalize ! - pack_read_binary ! - pack_write_grib2 ! - pack_write_netcdf ! - check ! !Calling Sequence: ! N/A ! !Inputs: ! N/A ! !Outputs: ! N/A ! !System Calls: ! N/A ! !History: ! 2014-10-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS ! !---------------------------------------------------------------------------- MODULE pack_outputs_mod USE type_kinds USE GETD_constants_mod USE GETD_log_mod IMPLICIT NONE PRIVATE !----------------------------------------------------------------------------- ! !PUBLIC MEMBER FUNCTIONS: !----------------------------------------------------------------------------- PUBLIC :: pack_read_config PUBLIC :: pack_init PUBLIC :: pack_finalize PUBLIC :: pack_read_binary PUBLIC :: pack_write_grib2 PUBLIC :: pack_write_netcdf PRIVATE :: check !----------------------------------------------------------------------------- ! !PUBLIC TYPES: !----------------------------------------------------------------------------- PUBLIC :: PackDataType ! Data structure holding the information and datasets ! locations for output pack processing. ! Input binary data row and col numbers are read from the configuration file. ! Input/Output data path and files name also need to be obtained from the ! configuration file. !---Declaration sections TYPE :: PackDataType ! Input file names ! Flag to indicate if the input evi is global or a region ! 0 - global, extract the evi from global input ! 1 - region, directly read from the binary file, no extraction needed INTEGER :: netcdf_flag INTEGER :: grib2_flag !Spatial information used to read input binary file INTEGER(Long) :: in_row_num, in_col_num REAL(Single) :: in_east_lon, in_west_lon REAL(Single) :: in_north_lat, in_south_lat ! REAL(Single) :: in_lat_resolution REAL(Single) :: in_lon_resolution REAL(Single) :: in_fill_value CHARACTER(LONG_STR) :: in_path CHARACTER(LONG_STR) :: in_et_file CHARACTER(LONG_STR) :: in_et_qc_file CHARACTER(LONG_STR) :: in_esi_2week_file CHARACTER(LONG_STR) :: in_esi_2week_qc_file CHARACTER(LONG_STR) :: in_esi_4week_file CHARACTER(LONG_STR) :: in_esi_4week_qc_file CHARACTER(LONG_STR) :: in_esi_8week_file CHARACTER(LONG_STR) :: in_esi_8week_qc_file CHARACTER(LONG_STR) :: in_esi_12week_file CHARACTER(LONG_STR) :: in_esi_12week_qc_file CHARACTER(LONG_STR) :: in_hday_file CHARACTER(LONG_STR) :: in_hday_qc_file CHARACTER(LONG_STR) :: in_gday_file CHARACTER(LONG_STR) :: in_gday_qc_file CHARACTER(LONG_STR) :: in_sdday_file CHARACTER(LONG_STR) :: in_sdday_qc_file CHARACTER(LONG_STR) :: in_snetday_file CHARACTER(LONG_STR) :: in_snetday_qc_file CHARACTER(LONG_STR) :: in_lwdnday_file CHARACTER(LONG_STR) :: in_lwdnday_qc_file CHARACTER(LONG_STR) :: in_lwupday_file CHARACTER(LONG_STR) :: in_lwupday_qc_file ! Output data path and file name CHARACTER(LONG_STR) :: out_path CHARACTER(LONG_STR) :: out_netcdf_file CHARACTER(LONG_STR) :: out_grib2_file ! Dynamic memories holding the inputs REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_et_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_et_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_2week REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_2week_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_4week REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_4week_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_8week REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_8week_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_12week REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_esi_12week_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_gday_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_gday_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_hday_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_hday_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_sdday_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_sdday_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_snetday_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_snetday_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_lwdnday_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_lwdnday_qc REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_lwupday_data REAL(Single), ALLOCATABLE, DIMENSION(:,:) :: in_lwupday_qc ! Added QC flags for output REAL(Single) :: et_mean REAL(Single) :: gday_mean REAL(Single) :: hday_mean REAL(Single) :: sdday_mean REAL(Single) :: snetday_mean REAL(Single) :: lwdnday_mean REAL(Single) :: lwupday_mean REAL(Single) :: esi_2week_mean REAL(Single) :: esi_4week_mean REAL(Single) :: esi_8week_mean REAL(Single) :: esi_12week_mean END TYPE PackDataType CONTAINS !=============================================================== ! Name: pack_read_config ! ! Type: Subroutine ! ! Function: ! Read in the spatial information of ET and ESI and ! input/output file locations. ! ! Description: ! Top 5 lines reserved for comments ! Files Needed: ! - GETD_pack_8km.cfg ! ! Modules Needed: ! - None ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! N/A ! ! Input: ! Name Type Description ! --------------------------------------------------- ! in_file_name I configure file name ! ! Output: ! Name Type Description ! --------------------------------------------------- ! pack_data O Data type holding configure ! information and dynamic memory. ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! ! System Calls: ! None ! ! History: ! 2014-09-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS ! !=============================================================== SUBROUTINE pack_read_config(in_file_name, pack_data, return_status) ! !USES:: USE GETD_constants_mod USE file_io_mod ! !PUBLIC TYPES: IMPLICIT NONE ! --------- ! Arguments ! --------- CHARACTER(LONG_STR), INTENT(in ) :: in_file_name TYPE(PackDataType), INTENT(out) :: pack_data INTEGER(Long), INTENT(out) :: return_status ! ---------------- ! Local variables ! --------------- INTEGER(Long) :: file_status, i, input_unit CHARACTER(LONG_STR) str_temp input_unit = GETD_get_next_unit_number() OPEN(input_unit, & iostat = file_status, & file =in_file_name, & form = 'formatted', & status = 'old') IF (file_status /= SUCCESS) THEN WRITE(GETD_logunit,*) & 'Error in opening the output pack configuration file' return_status = FAILURE RETURN ELSE ! Read in the information in the configuration file DO i = 1, 5 READ(input_unit,10) str_temp !Skip the commented line END DO ! Input pack_data file domain information READ(input_unit,25) pack_data%in_east_lon READ(input_unit,25) pack_data%in_west_lon READ(input_unit,25) pack_data%in_lon_resolution READ(input_unit,25) pack_data%in_north_lat READ(input_unit,25) pack_data%in_south_lat READ(input_unit,25) pack_data%in_lat_resolution READ(input_unit,15) pack_data%in_col_num READ(input_unit,15) pack_data%in_row_num READ(input_unit,25) pack_data%in_fill_value !Input path and file names READ(input_unit,10) str_temp !comment line READ(input_unit,10) pack_data%in_path READ(input_unit,10) pack_data%in_et_file READ(input_unit,10) pack_data%in_et_qc_file READ(input_unit,10) pack_data%in_hday_file READ(input_unit,10) pack_data%in_hday_qc_file READ(input_unit,10) pack_data%in_gday_file READ(input_unit,10) pack_data%in_gday_qc_file READ(input_unit,10) pack_data%in_sdday_file READ(input_unit,10) pack_data%in_sdday_qc_file READ(input_unit,10) pack_data%in_snetday_file READ(input_unit,10) pack_data%in_snetday_qc_file READ(input_unit,10) pack_data%in_lwdnday_file READ(input_unit,10) pack_data%in_lwdnday_qc_file READ(input_unit,10) pack_data%in_lwupday_file READ(input_unit,10) pack_data%in_lwupday_qc_file !ESI inputs data and QC READ(input_unit,10) pack_data%in_esi_2week_file READ(input_unit,10) pack_data%in_esi_2week_qc_file READ(input_unit,10) pack_data%in_esi_4week_file READ(input_unit,10) pack_data%in_esi_4week_qc_file READ(input_unit,10) pack_data%in_esi_8week_file READ(input_unit,10) pack_data%in_esi_8week_qc_file READ(input_unit,10) pack_data%in_esi_12week_file READ(input_unit,10) pack_data%in_esi_12week_qc_file ! Output control flags READ(input_unit,10) str_temp !comment line READ(input_unit,15) pack_data%netcdf_flag READ(input_unit,15) pack_data%grib2_flag ! Output reference ET and pack_data files READ(input_unit,10) str_temp !comment line READ(input_unit,10) pack_data%out_path READ(input_unit,10) pack_data%out_netcdf_file READ(input_unit,10) pack_data%out_grib2_file END IF return_status = SUCCESS CLOSE(input_unit) CALL GETD_release_unit_number(input_unit) !formats to read in the inputs 10 FORMAT (30x, a300) !format to read in the string after 30 spaces 15 FORMAT (30x, i10) !format to read in the integer number, one per line 20 FORMAT (30x, f7.2) !format to read in the real value, one per line 25 FORMAT (30x, e12.3) 30 FORMAT (30x, a4) !format to read in the string after 30 spaces END SUBROUTINE pack_read_config !=============================================================== ! Name: pack_init ! ! Type: Subroutine ! ! Function: ! Allocate the memory spaces for the pack data processing. ! ! Description: ! Called after the read_config module for initialing the ! internal memory with the dimension information read in. ! ! Files Needed: ! - None ! ! Modules Needed: ! - None ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! CALL pack_init (pack_data, return_status) ! ! Input: ! Name Type Description ! --------------------------------------------------- ! pack_data I/O Data type used for pack processing. ! ! Output: ! Name Type Description ! --------------------------------------------------- ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! ! System Calls: ! None ! ! History: ! 2014-10-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS !=============================================================== SUBROUTINE pack_init (pack_data, return_status) ! ---------- ! Module use ! ---------- USE type_kinds USE GETD_constants_mod USE GETD_log_mod ! --------------------------- ! Disable all implicit typing ! --------------------------- IMPLICIT NONE ! --------- ! Arguments ! --------- TYPE(PackDataType) :: pack_data INTEGER(Long), INTENT(out) :: return_status ! --------------- ! Local variables ! --------------- INTEGER(Long) :: istat return_status = SUCCESS ! Check the input information of the matrix ! ------------------------------------------------------------------- ! Allocate the memory for the input 2-D pack data boundary_if: IF ( (pack_data%in_col_num < 1 .OR. & pack_data%in_row_num < 1) ) THEN WRITE(GETD_logunit,*)'Input pack boundary error ! Init process exit.' return_status = FAILURE ELSE ! Input data ! Daily ET and QC ALLOCATE(pack_data%in_et_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack ET data error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_et_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack ET QC error' return_status = FAILURE RETURN END IF ! Daily G flux ALLOCATE(pack_data%in_gday_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack daily G error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_gday_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily G QC error' return_status = FAILURE RETURN END IF ! Daily H flux ALLOCATE(pack_data%in_hday_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack daily H error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_hday_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily H QC error' return_status = FAILURE RETURN END IF ! Daily SD flux ALLOCATE(pack_data%in_sdday_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily SD error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_sdday_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily SD QC error' return_status = FAILURE RETURN END IF ! Daily SNET flux ALLOCATE(pack_data%in_snetday_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily SNET error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_snetday_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily SNET QC error' return_status = FAILURE RETURN END IF ! Daily LWDN flux ALLOCATE(pack_data%in_lwdnday_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily LWDN error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_lwdnday_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily LWDN QC error' return_status = FAILURE RETURN END IF ! Daily LWUP flux ALLOCATE(pack_data%in_lwupday_data(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily LWUP error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_lwupday_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate daily LWUP QC error' return_status = FAILURE RETURN END IF ! ESI 2 weeks and QC ALLOCATE(pack_data%in_esi_2week( & pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_2week error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_esi_2week_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_2week_qc error' return_status = FAILURE RETURN END IF ! ESI 4 weeks ALLOCATE(pack_data%in_esi_4week( & pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_4week error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_esi_4week_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_4week_qc error' return_status = FAILURE RETURN END IF ! ESI 8 weeks ALLOCATE(pack_data%in_esi_8week( & pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_8week error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_esi_8week_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_8week_qc error' return_status = FAILURE RETURN END IF ! ESI 12 weeks ALLOCATE(pack_data%in_esi_12week( & pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_12week error' return_status = FAILURE RETURN END IF ALLOCATE(pack_data%in_esi_12week_qc(& pack_data%in_col_num,pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate pack in_esi_12week_qc error' return_status = FAILURE RETURN END IF END IF boundary_if END SUBROUTINE pack_init !------------------------------------------------------------------- !=============================================================== ! Name: pack_finalize ! ! Type: Subroutine ! ! Function: ! Release the allocated memory for the pack processing usage. ! ! Description: ! Check all the dynamic memory and release them ! if they were allocated. ! ! Files Needed: ! - None ! ! Modules Needed: ! - None ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! CALL pack_finalize(pack_data, return_status) ! ! Input: ! Name Type Description ! --------------------------------------------------- ! pack_data I/O pack data ! ! Output: ! Name Type Description ! --------------------------------------------------- ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! ! System Calls: ! None ! ! History: ! 2014-10-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS !=============================================================== SUBROUTINE pack_finalize(pack_data, return_status) USE GETD_constants_mod IMPLICIT NONE TYPE(PackDataType) :: pack_data INTEGER(Long), INTENT(out) :: return_status ! Local variables INTEGER(Long) :: istat ! ------------------------------------------------------------------- ! Release the memory for the 2-D input data variables DEALLOCATE(pack_data%in_et_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_et_data error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_et_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_et_qc error' return_status = FAILURE END IF ! Daily G fluxes DEALLOCATE(pack_data%in_gday_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_gday_data error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_gday_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_gday_qc error' return_status = FAILURE END IF ! Daily H fluxes DEALLOCATE(pack_data%in_hday_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_hday_data error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_hday_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_hday_qc error' return_status = FAILURE END IF ! Daily SD fluxes DEALLOCATE(pack_data%in_sdday_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_sdday_data error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_sdday_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_sdday_qc error' return_status = FAILURE END IF ! Daily SNET fluxes DEALLOCATE(pack_data%in_snetday_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_snetday_data error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_snetday_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_snetday_qc error' return_status = FAILURE END IF ! Daily LWDN fluxes DEALLOCATE(pack_data%in_lwdnday_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate in_lwdnday_data error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_lwdnday_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate in_lwdnday_qc error' return_status = FAILURE END IF ! Daily LWUP fluxes DEALLOCATE(pack_data%in_lwupday_data, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate lwup error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_lwupday_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate lwup day QC error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_2week, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_2week error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_2week_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_2week QC error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_4week, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_4week error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_4week_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_4week QC error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_8week, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_8week error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_8week_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_8week QC error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_12week, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_12week error' return_status = FAILURE END IF DEALLOCATE(pack_data%in_esi_12week_qc, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate pack in_esi_12week QC error' return_status = FAILURE END IF WRITE(GETD_logunit,'(a)') 'release pack memory successfully' return_status = SUCCESS END SUBROUTINE pack_finalize !=============================================================== ! Name: pack_read_binary ! ! Type: Subroutine ! ! Function: ! Read in the input binary files to create the GRIB2 ! and NETCDF file outputs. ! Descriptions: ! Read in the daily fluxes data files and the ! ESI data files. Then compute the statics. ! ! Files Needed: ! - configure file ! - Input ESI data file ! - Input daily fluxes data files ! ! Modules Needed: ! - None ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! CALL pack_read_binary( pack_data, & ! in_year, in_doy, istat) ! ! Input: ! Name Type Description ! --------------------------------------------------- ! in_year I Year ! in_doy I Day of the year ! ! Output: ! Name Type Description ! --------------------------------------------------- ! pack_data I/O Data structure of the ! input/output config ! and dynamic memories. ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! !=============================================================== SUBROUTINE pack_read_binary( pack_data, & in_year, in_doy, return_status) ! ---------- ! Module use ! ---------- USE type_kinds USE GETD_constants_mod USE GETD_log_mod USE file_io_mod ! --------------------------- ! Disable all implicit typing ! --------------------------- IMPLICIT NONE ! --------- ! Arguments ! --------- TYPE(PackDataType) :: pack_data INTEGER(Long), INTENT( in) :: in_year, in_doy INTEGER(Long), INTENT(out) :: return_status ! Local variables INTEGER(Long) :: i, j INTEGER(Long) :: istat, output_unit INTEGER(Long) :: count_et, count_esi_2week INTEGER(Long) :: count_esi_4week, count_esi_8week INTEGER(Long) :: count_esi_12week CHARACTER(LONG_STR) :: file_name CHARACTER(9) :: yyyydoy_str REAL(Single) :: sum_et, sum_esi_2week, sum_esi_4week REAL(Single) :: sum_esi_8week, sum_esi_12week LOGICAL :: lexist return_status = SUCCESS ! Locate the file with the path and time information WRITE(yyyydoy_str,'(a1,i4.4, i3.3,a1)')'/',in_year, in_doy, '/' ! Read in ET and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_et_file) ! Note we want to change the ! CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_et_data, istat) ! convert the ET unit from MJ m-2 day-1 to mm day-1 ! http://www.fao.org/docrep/x0490e/x0490e0i.htm ! equivalent radiation in megajoules per ! square metre per day (MJ m-2 day-1) ! 1 MJ m-2 day-1 = 0.408 mm day-1 do j = 1, pack_data%in_col_num do i = 1, pack_data%in_row_num if ( pack_data%in_et_data(j,i) > & pack_data%in_fill_value) then pack_data%in_et_data(j,i) = & pack_data%in_et_data(j,i) * 0.408 endif end do end do IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_et_qc_file) ! CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_et_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF ! Read in Daily G and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_gday_file) CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_gday_data, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_gday_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_gday_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF ! Read in Daily H and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_hday_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_hday_data, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_hday_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_hday_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF ! Read in Daily SD and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_sdday_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_sdday_data, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_sdday_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_sdday_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF ! Read in Daily SNET and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_snetday_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_snetday_data, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_snetday_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_snetday_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF ! Read in Daily LWDN and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_lwdnday_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_lwdnday_data, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_lwdnday_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_lwdnday_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF ! Read in Daily LWUP and QC from binary file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_lwupday_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_lwupday_data, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_lwupday_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_lwupday_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF !------------------------------------------------------------------- ! Read in ESI and QCs from binary file ! 2 weeks WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_2week_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_2week, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') trim(file_name), ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_2week_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_2week_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF ! 4 weeks WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_4week_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_4week, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_4week_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_4week_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF ! 8 weeks WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_8week_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_8week, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_8week_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_8week_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF ! 12 weeks WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_12week_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_12week, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF ! ESI QC file WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & yyyydoy_str, TRIM(pack_data%in_esi_12week_qc_file) !CALL read_2d_real_by_col_row(file_name, & CALL read_2d_real_by_col_row_reverse(file_name, & pack_data%in_col_num, pack_data%in_row_num, & pack_data%in_fill_value, pack_data%in_esi_12week_qc, istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit, '(a,a)') file_name, ' read failed!' return_status = FAILURE RETURN END IF write(*,*)'Read all data binary in', return_status, pack_data%in_fill_value ! Compute the mean values for all the input variables sum_et = 0 sum_esi_2week = 0 sum_esi_4week = 0 sum_esi_8week = 0 sum_esi_12week = 0 count_et = 0 count_esi_2week = 0 count_esi_4week = 0 count_esi_8week = 0 count_esi_12week = 0 do j = 1, pack_data%in_col_num do i = 1, pack_data%in_row_num ! if ( abs (pack_data%in_et_data(j,i) - & ! pack_data%in_fill_value ) > 1e-6 ) then if ( pack_data%in_et_data(j,i) .ne. & pack_data%in_fill_value ) then sum_et = sum_et + pack_data%in_et_data(j,i) count_et = count_et + 1 endif ! if ( pack_data%in_esi_2week(j,i) .ne. & ! pack_data%in_fill_value) then if ( (pack_data%in_esi_2week(j,i) > -5.) .and. & (pack_data%in_esi_2week(j,i) < 5.)) then sum_esi_2week = sum_esi_2week + pack_data%in_esi_2week(j,i) count_esi_2week = count_esi_2week + 1 endif ! if ( pack_data%in_esi_4week(j,i) .ne. & ! pack_data%in_fill_value) then if ( (pack_data%in_esi_4week(j,i) > -10.) .and. & (pack_data%in_esi_4week(j,i) < 10.)) then sum_esi_4week = sum_esi_4week + pack_data%in_esi_4week(j,i) count_esi_4week = count_esi_4week + 1 endif ! if ( pack_data%in_esi_8week(j,i) .ne. & ! pack_data%in_fill_value) then if ( (pack_data%in_esi_8week(j,i) > -10.) .and. & (pack_data%in_esi_8week(j,i) < 10.)) then sum_esi_8week = sum_esi_8week + pack_data%in_esi_8week(j,i) count_esi_8week = count_esi_8week + 1 endif ! if ( pack_data%in_esi_12week(j,i) .ne. & ! pack_data%in_fill_value) then if ( (pack_data%in_esi_12week(j,i) > -10.) .and. & (pack_data%in_esi_12week(j,i) < 10.)) then sum_esi_12week = sum_esi_12week + pack_data%in_esi_12week(j,i) count_esi_12week = count_esi_12week + 1 endif end do end do if ( count_et > 0 ) then pack_data%et_mean = sum_et / count_et endif if ( count_esi_2week > 0 ) then pack_data%esi_2week_mean = sum_esi_2week / count_esi_2week endif if ( count_esi_4week > 0 ) then pack_data%esi_4week_mean = sum_esi_4week / count_esi_4week endif if ( count_esi_8week > 0 ) then pack_data%esi_8week_mean = sum_esi_8week / count_esi_8week endif if ( count_esi_12week > 0 ) then pack_data%esi_12week_mean = sum_esi_12week / count_esi_12week endif ! Write to an output txt file ! the QC file should be in the save dir as other input files ! Open the TXT file for output, if exists, append at the end WRITE(file_name,'(a,a8,i4.4,i3.3,a4)') & TRIM(pack_data%out_path), & '/GETD_QF', in_year, in_doy, '.txt' INQUIRE (FILE=file_name, EXIST=lexist) exists: IF (.NOT. lexist ) THEN open(output_unit, iostat = istat, & file = file_name, & status = 'NEW', ACTION='WRITE') ! WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & ! yyyydoy_str, TRIM(pack_data%in_esi_2week_file) ! write(output_unit, '(a30,a)')'2week filename:', & ! trim(file_name) ! WRITE(file_name,'(a,a9,a)')TRIM(pack_data%in_path), & ! yyyydoy_str, TRIM(pack_data%in_et_file) ! write(output_unit, '(a30,a)')'ET filename:', & ! trim(file_name) ELSE !If the file exists, then just added the info in the behind open(output_unit, iostat = istat, & file = file_name, & POSITION= 'APPEND', & status = 'OLD', & ACTION='WRITE') ENDIF exists if ( istat == SUCCESS) then ! write(output_unit, '(a30,f15.5)')'sum_et:', & ! sum_et ! write(output_unit, '(a30,i15)')'count_et:', & ! count_et ! write(output_unit, '(a30,f15.5)')'sum_esi_2week:', & ! sum_esi_2week ! write(output_unit, '(a30,i15)')'count_esi_2week:', & ! count_esi_2week ! write(output_unit, '(a30,f15.5)')'sum_esi_4week:', & ! sum_esi_4week ! write(output_unit,'(a30,i7,i3.3)') & ! 'GETD QF INFO ON:', in_year, in_doy write(output_unit, '(a30,f15.5)')'Mean ET(MJ m-2 day-1):', & pack_data%et_mean write(output_unit, '(a30,f15.5)')'Mean ESI 2 weeks:', & pack_data%esi_2week_mean write(output_unit, '(a30,f15.5)')'Mean ESI 4 weeks:', & pack_data%esi_4week_mean write(output_unit, '(a30,f15.5)')'Mean ESI 8 weeks:', & pack_data%esi_8week_mean write(output_unit, '(a30,f15.5)')'Mean ESI 12 weeks:', & pack_data%esi_12week_mean else WRITE(GETD_logunit,'(a,a,a)')'Open ', trim(file_name), ' error!' endif close(output_unit) END SUBROUTINE pack_read_binary !=============================================================== ! Name: pack_write_grib2 ! ! Type: Subroutine ! ! Function: ! Write the GETD output binary data into GRIB2 file format. ! ! Description: ! More information can be found below: ! http://www.nco.ncep.noaa.gov/pmb/docs/grib2/download/g2lib.documentation ! ! Files Needed: ! - None ! ! Modules Needed: ! - None ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! CALL pack_write_grib2(pack_data, istat) ! ! Input: ! Name Type Description ! --------------------------------------------------- ! pack_data I Data type holding configure ! information and dynamic memory. ! in_year I Year ! in_doy I Day of the year ! ! Output: ! Name Type Description ! --------------------------------------------------- ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! ! System Calls: ! None ! ! History: ! 2014-03-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS ! 2015-09-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS ! Updated with new Fluxes and ESI values !=============================================================== ! SUBROUTINE pack_write_grib2(pack_data, & in_year, in_doy, return_status) ! ---------- ! Module use ! ---------- USE type_kinds USE GETD_constants_mod USE GETD_log_mod USE grib_mod USE sunrise_mod ! --------------------------- ! Disable all implicit typing ! --------------------------- ! IMPLICIT NONE TYPE(PackDataType), INTENT(in) :: pack_data INTEGER(Long ), INTENT(in) :: in_year INTEGER(Long ), INTENT(in) :: in_doy INTEGER, INTENT(out) :: return_status ! ---------------- ! Local parameters ! ---------------- ! Fixed parameters in GRIB2 MESSAGE INTEGER ( Long ), PARAMETER :: igdstmplen = 19 INTEGER ( Long ), PARAMETER :: ipdstmplen = 15 INTEGER ( Long ), PARAMETER :: idrstmplen = 5 INTEGER ( Long ), PARAMETER :: numcoord = 1 ! Fixed parameters for the ESI file ! There will be 10 fields written to the GRIB2 ! file. 5 variables and 5 QC fields. ! Updated with additional 6 variables and 6 QC ! so total is 22 fields, 10/15/2015, not done yet ! ET is INTEGER ( Long ), PARAMETER :: numfields = 22 INTEGER ( Long ), PARAMETER :: startmsg = 231 ! --------------- ! Local variables ! --------------- INTEGER ( Long ) :: file_status, input_unit, istat INTEGER ( Long ) :: cur_mon, cur_day INTEGER(Short), DIMENSION(:,:), ALLOCATABLE :: data_out INTEGER(bByte), DIMENSION(:,:), ALLOCATABLE :: qc_out REAL(Single), DIMENSION(:), ALLOCATABLE :: lat, lon INTEGER ( Long ) :: GRIB_fileID INTEGER ( Long ) :: listsec0(2) INTEGER ( Long ) :: listsec1(13) INTEGER ( Long ) :: igds(5) INTEGER ( Long ) :: igdstmpl(igdstmplen) INTEGER ( Long ) :: ipdstmpl(ipdstmplen) INTEGER ( Long ) :: idrstmpl(idrstmplen) CHARACTER (LEN=80) :: lsec2 CHARACTER (LEN=80) :: title ! Number of points in the output INTEGER ( Long ) :: ngrdpts ! File size, notice that the 4 is the byte length INTEGER ( Long ) :: lcgrib CHARACTER (LEN=1), DIMENSION(:), ALLOCATABLE :: cgrib ! Product Definition Template Number (Code Table 4.0) INTEGER ( Long ) :: ipdsnum = 0 ! 0 Analysis or forecast at a horizontal level or ! in a horizontal layer at a point in time. INTEGER ( Long ) :: idrsnum INTEGER ( Long ) :: ibmap INTEGER ( Long ) :: ierr INTEGER ( Long ) :: lengrib REAL ( Single ), DIMENSION(:,:), ALLOCATABLE :: fld REAL ( Single ) :: coordlist(numcoord) LOGICAL*1, DIMENSION(:,:), ALLOCATABLE :: bmap ! end of GRIB2 variables CHARACTER(LONG_STR) :: str_temp CHARACTER(LONG_STR) :: file_name CHARACTER(9) :: yyyydoy_str INTEGER :: i ! Locate the file with the path and time information ! The format of the file will be ! WRITE(yyyydoy_str,'(a1,i4.4, i3.3,a1)')'_',in_year, in_doy, '.' ! Set the name of the output GRIB2 file with output path information ! and time information WRITE(file_name,'(a,a1,a,a9,a)')TRIM(pack_data%out_path), & '/', TRIM(pack_data%out_grib2_file), yyyydoy_str, 'grb2' write(*,*)'Write GRIB2', trim(file_name) call get_mmdd_by_yyyydoy(in_year, in_doy, cur_mon, cur_day) date_if: if ( cur_mon > 0 .and. cur_day > 0 ) then ngrdpts = pack_data%in_col_num * pack_data%in_row_num ! This define the size of the GRIB2 message, has to be larger ! or equal than all the fields written into the GRIB2 file. lcgrib = ngrdpts * Single * numfields ALLOCATE(fld(pack_data%in_col_num, pack_data%in_row_num)) ALLOCATE(bmap(pack_data%in_col_num, pack_data%in_row_num)) ALLOCATE(cgrib(lcgrib)) ! Get the month and day in the month using day of the year information !1 Grid Definition Templates !2 Product Definition Templates !3 Data Representation Data Templates !4 Data Templates !------------------------------------------------------------------------------ ! Fill in the GRIB Master table number ! Section 1: Identification Section ! Discipline-GRIB Master Table Number (see Code Table 0.0) listsec0(1) = 2 ! 2 - Land surface products ! GRIB Edition Number (currently 2) listsec0(2) = 2 ! Id of originating centre (Common Code Table C-1) listsec1(1) = 7 ! 7 - US NOAA/NCEP ! Id of originating sub-centre (local sub-Centres table) listsec1(2) = 1 ! 1 - US NOAA/NESDIS ! GRIB Master Tables Version Number (Code Table 1.0) listsec1(3) = 2 ! 2 - Version Implemented on 4 Novembe 2003 ! GRIB Local Tables Version Number (Code Table 1.1) listsec1(4) = 1 ! 1 - Local tables not used. ! Significance of Reference Time (Code Table 1.2) listsec1(5) = 01 ! 1 - Start of Forecast listsec1(6) = in_year ! Reference Time - Year (4 digits) ! convert the day of year to month and day listsec1(7) = cur_mon ! Reference Time - Month listsec1(8) = cur_day ! Reference Time - Day listsec1(9) = 0 ! Reference Time - Hour listsec1(10) = 0 ! Reference Time - Minute listsec1(11) = 0 ! Refe:rence Time - Second listsec1(12) = 0 ! Production status of data (Code Table 1.3) ! 0 - Operational products listsec1(13) = 6 ! Type of processed data (Code Table 1.4) ! 6 - Processed satellite obeservations !---------------------------------------------------------------------------- ! set up grid definition section igds(1) = 0 ! Source of grid definition (see Code Table 3.0) ! 0 - Specified in Table 3.1 igds(2) = ngrdpts ! Number of grid points in the defined grid. igds(3) = 0 ! Number of octets needed for each additional ! grid points definition igds(4) = 0 ! Interpretation of list for optional points definition. ! (Code Table 3.11) ! 0 - There is no appended list ! Grid Definition Template Number (Code Table 3.1) ! 0 - Latitude/longitude igds(5) = 0 !---------------------------------------------------------------------------- ! Set up grid definition section igdstmpl(1) = 6 ! Shape of earth (Code Table 3.2) ! 6 - Earth assumed spherical with radius = 6,371,229.0 m igdstmpl(2:7) = 0 ! Not needed for Shape of earth = 6 igdstmpl(8) = pack_data%in_col_num ! number of points along a parallel igdstmpl(9) = pack_data%in_row_num ! number of points along a meridian igdstmpl(10:11) = 0 ! Basic angle of the initial production domain and ! subdivisions of this basic angle ! Latitude of first grid point igdstmpl(12) = NINT(pack_data%in_south_lat*1000000) ! Latitude of first grid point ! igdstmpl(13) = NINT(-136.95*1000000)! Longitude of first grid point if ( pack_data%in_west_lon < 0 ) then ! Convert to 0~360 igdstmpl(13) = NINT((pack_data%in_west_lon+360)*1000000) else igdstmpl(13) = NINT(pack_data%in_west_lon*1000000) ! Convert to 0~360 endif ! Resolution and Component Flags, see Flag Table 3.3 ! 48 (00110000) - both i and j direction increments are given igdstmpl(14) = 48 ! Latitude of last grid point igdstmpl(15) = NINT(pack_data%in_north_lat*1000000) if ( pack_data%in_east_lon < 0 ) then ! Convert to 0~360 igdstmpl(16) = NINT((pack_data%in_east_lon+360)*1000000) else ! Convert to 0~360 igdstmpl(16) = NINT(pack_data%in_east_lon*1000000) endif ! i direction increment ( west to east) igdstmpl(17) = NINT(pack_data%in_lon_resolution*1000000) ! j direction increment ( north to south) igdstmpl(18) = NINT(pack_data%in_lat_resolution*1000000) ! 0 means from North to South(lat decrease) ! from west to east igdstmpl(19) = 0 ! Scanning Mode. Flag Table 3.4. !------------------------------------------------------------------ ! Set up product definition section ! Parameter category ! (see Code table 4.1, Product discipline 2 - Land surface product) ipdstmpl(1) = 0 ! 0 - Vegetation/Biomass category ! Parameter number, see Code table 4.2, ! GRIB2 - TABLE 4.2-2-0 ! PARAMETERS FOR DISCIPLINE 2 CATEGORY 0 ! (Land Surface products, Vegetation/Biomass category) ! 6 - Evapotranspiration, Unit: kg-2 s-1, Abbrev:EVAPT ipdstmpl(2) = 6 ! Type of generating process (see Code table 4.3) ipdstmpl(3) = 0 ! 0 - Analysis ipdstmpl(4) = 0 ! Background generating process identifier ! (defined by originating centre) ipdstmpl(5) = 220 ! Analysis or forecast generating process identified ! (see Code ON388 Table A) ! 220 - NCEP/OPC automated product ! Hours of observational data cutoff after reference time ipdstmpl(6) = 0 ipdstmpl(7) = 0 ! Minutes of observational data cutoff ! after reference time ipdstmpl(8) = 1 ! Indicator of unit of time range (see Code table 4.4) ipdstmpl(9) = 0 ! Forecast time in units defined by octet 18 ipdstmpl(10) = 1 ! Type of first fixed surface (see Code table 4.5) ipdstmpl(11) = 0 ! Scale factor of first fixed surface ipdstmpl(12) = 0 ! Scaled value of first fixed surface ipdstmpl(13) = 255 ! Type of second fixed surfaced (see Code table 4.5) ipdstmpl(14) = 0 ! Scale factor of second fixed surface ipdstmpl(15) = 0 ! Scaled value of second fixed surfaces coordlist = 0 idrsnum = 0 ! Data Representation Template Number (see Code Table 5.0) ! 0 - Grid Point Data - Simple Packing idrstmpl(1) = 0 ! Reference value (R) (IEEE 32-bit floating-point value) ! (will be overwritten and needs to be reset to 0 after each addfield() call) idrstmpl(2) = 0 ! Binary scale factor (E) ! (will be overwritten and needs to be resetafter each addfield() call) idrstmpl(3) = 4 ! Decimal scale factor (D) ! (4 for all SM fields and 0 for all others) ! (will be overwritten and needs to be resetafter each addfield() call) idrstmpl(4) = 0 ! Number of bits used for each packed value for simple ! packing ! (will be overwritten and needs to be reset after each addfield() call) idrstmpl(5) = 0 ! Type of original field values ibmap = 0 ! Bitmap indicator ( see Code Table 6.0 ) ! (0:bitmap applies and is included in Section 6.) ! Adding one field into the message ! Check the input data bmap(:,:) = .TRUE. fld(:,:) = pack_data%in_et_data(:,:) !ENDWHERE !------------------------------------------------------ ! Start adding fileds to GRIB2 message ! ! GRIBCREATE ! ... ! ADDLOCAL (optional) ! ... ! ADDGRID ! ... ! ADDFIELD ! ... ! GRIBEND ! ... WRITE(GETD_logunit, *)'Creating GRIB2 message...' CALL gribcreate(cgrib, lcgrib, listsec0, listsec1, return_status) WRITE(GETD_logunit, *) 'Adding grid to GRIB2 message...' CALL addgrid(cgrib, lcgrib, igds, igdstmpl, igdstmplen, & 0, 0, return_status) WRITE(GETD_logunit, *) 'Adding one field to GRIB2 message...' ! Update the product template ipdstmpl(2) = 6 ! 6 is for ET ! reset the Data Representation Template idrstmpl = 0 IF (COUNT(bmap) == 0) THEN idrstmpl(3) = 0 ! Decimal scale factor (D) 0 if all Fill Value ELSE idrstmpl(3) = 4 ! Decimal scale factor (D) 4 for all valid fields END IF CALL addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, & coordlist, numcoord, idrsnum, idrstmpl, & idrstmplen, fld, ngrdpts, ibmap, bmap, return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, *) 'Error adding ET field to GRIB2 message ' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *) 'Adding ET field to GRIB2 message done.' END IF ! add QC layer ! Update the product template ! Since all the output variables except ET has ! correspond number in the table, just use ! some reserved number ipdstmpl(2) = startmsg ! Using reserved value ! Put in the real value here bmap(:,:) = .TRUE. fld(:,:) = pack_data%in_et_qc(:,:) !ENDWHERE ! reset the value for QC, no scaling factor is used ! for this idrstmpl = 0 CALL addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, & coordlist, numcoord, idrsnum, idrstmpl, & idrstmplen, fld, ngrdpts, ibmap, bmap, return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, *) 'Error adding QC field to GRIB2 message ' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *) 'Adding QC field to GRIB2 message done.' END IF ! loop for 2, 4, 8, 12 esi_loop: DO i = 1, 4 ! Update the product template ipdstmpl(2) = startmsg + i ! Increase the number of field ! reset the Data Representation idrstmpl = 0 ! Put in the ESI weekly value here if ( i == 1 ) then fld(:,:) = pack_data%in_esi_2week(:,:) else if ( i == 2 ) then fld(:,:) = pack_data%in_esi_4week(:,:) else if ( i == 3 ) then fld(:,:) = pack_data%in_esi_8week(:,:) else if ( i == 4 ) then fld(:,:) = pack_data%in_esi_12week(:,:) endif !ENDWHERE bmap(:,:) = .TRUE. CALL addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, & coordlist, numcoord, idrsnum, idrstmpl, & idrstmplen, fld, ngrdpts, ibmap, bmap, return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, '(a,i2,a)') & 'Error adding ',i, 'the ESI field in GRIB2 message ' return_status = FAILURE ELSE WRITE(GETD_logunit, '(a,i2,a)') & 'Adding ',i,'th ESI to GRIB2 message done.' END IF end do esi_loop esi_qc_loop: DO i = 1, 4 ! add QC layer ! Update the product template ipdstmpl(2) = startmsg + i ! Using reserved value ! Put in the QC value here bmap(:,:) = .TRUE. if ( i == 1 ) then fld(:,:) = pack_data%in_esi_2week_qc(:,:) else if ( i == 2 ) then fld(:,:) = pack_data%in_esi_4week_qc(:,:) else if ( i == 3 ) then fld(:,:) = pack_data%in_esi_8week_qc(:,:) else if ( i == 4 ) then fld(:,:) = pack_data%in_esi_12week_qc(:,:) endif !ENDWHERE ! reset the value for QC, no scaling factor is used ! for the QC. CALL addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, & coordlist, numcoord, idrsnum, idrstmpl, & idrstmplen, fld, ngrdpts, ibmap, bmap, return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, *) 'Error adding ESI QC field to GRIB2 message ' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *) 'Adding ESI QC field to GRIB2 message done.' END IF END DO esi_qc_loop !----------------------------------------------------------------- ! Added the other daily fluxes data and QC flags daily_flux_loop: DO i = 1, 12 ! Add Daily fluxes ! gday ! hday ! sdday ! snetday ! lwdnday ! lwupday ! Update the product template ipdstmpl(2) = startmsg + i ! Increase the number of field ! reset the Data Representation idrstmpl = 0 ! Put in the ESI weekly value here if ( i == 1 ) then fld(:,:) = pack_data%in_gday_data(:,:) else if ( i == 2 ) then fld(:,:) = pack_data%in_gday_qc(:,:) else if ( i == 3 ) then fld(:,:) = pack_data%in_hday_data(:,:) else if ( i == 4 ) then fld(:,:) = pack_data%in_hday_qc(:,:) else if ( i == 5 ) then fld(:,:) = pack_data%in_sdday_data(:,:) else if ( i == 6 ) then fld(:,:) = pack_data%in_sdday_qc(:,:) else if ( i == 7 ) then fld(:,:) = pack_data%in_snetday_data(:,:) else if ( i == 8 ) then fld(:,:) = pack_data%in_snetday_qc(:,:) else if ( i == 9 ) then fld(:,:) = pack_data%in_lwdnday_data(:,:) else if ( i == 10 ) then fld(:,:) = pack_data%in_lwdnday_qc(:,:) else if ( i == 11 ) then fld(:,:) = pack_data%in_lwupday_data(:,:) else if ( i == 12 ) then fld(:,:) = pack_data%in_lwupday_qc(:,:) endif ! No scaling factor is used here idrstmpl = 0 CALL addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, & coordlist, numcoord, idrsnum, idrstmpl, & idrstmplen, fld, ngrdpts, ibmap, bmap, return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, *) 'Error adding field to GRIB2 message ', & startmsg + i return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *) 'Adding field to GRIB2 message done.', & startmsg + i END IF END DO daily_flux_loop !------------------------------------------------------ WRITE(GETD_logunit, *) 'Ending GRIB2 message...' CALL gribend(cgrib, lcgrib, lengrib, return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, *)'Error ending GRIB2 message ' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *)'Ending GRIB2 message done.' END IF ! Write the message to the file ! GRIB_fileID = GETD_get_next_unit_number() CALL baopenw (GRIB_fileID, TRIM(file_name), return_status) IF (return_status /= 0) THEN WRITE(GETD_logunit, *)'Error opening file', TRIM(file_name), & 'to write.' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *) 'GRIB2 file opened.' END IF !write the message to the file CALL wryte(GRIB_fileID, lengrib, cgrib) IF (return_status /= 0) THEN WRITE(GETD_logunit, *) 'Error writing GRIB2 message. ' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *)'GRIB2 message written.' END IF CALL baclose(GRIB_fileID, return_status) IF (return_status > 0) THEN WRITE(GETD_logunit, *)'Error closing GRIB2 file. ' return_status = FAILURE RETURN ELSE WRITE(GETD_logunit, *)'GRIB2 file closed.' END IF CALL GETD_release_unit_number(GRIB_fileID) ! if ( allocated(fld) ) then deallocate(fld, STAT=istat) if ( istat == SUCCESS) then write(GETD_logunit,*)'Free fld done.' else write(GETD_logunit,*)'fld error!' return_status = FAILURE endif endif if ( allocated(bmap) ) then deallocate(bmap, STAT=istat) endif if ( allocated(cgrib) ) then deallocate(cgrib, STAT=istat) endif return_status = SUCCESS else ! If the input day of year is out of range ! return with error return_status = FAILURE endif date_if END SUBROUTINE pack_write_grib2 !=============================================================== ! Name: pack_write_netcdf ! ! Type: Subroutine ! ! Function: ! Write the GETD output binary data into NETCDF file format. ! ! Description: ! Create the information of each NETCDF variable. ! ! NF90_CREATE ! create netCDF dataset: enter define mode ! ... ! NF90_DEF_DIM ! define dimensions: from name and length ! ... ! NF90_DEF_VAR ! define variables: from name, type, dims ! ... ! NF90_PUT_ATT ! assign attribute values ! ... ! NF90_ENDDEF ! end definitions: leave define mode ! ... ! NF90_PUT_VAR ! provide values for variable ! ... ! NF90_CLOSE ! close: save new netCDF dataset ! ! ! Files Needed: ! - None ! ! Modules Needed: ! - None ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! CALL pack_write_netcdf(pack_data, return_status) ! ! Input: ! Name Type Description ! --------------------------------------------------- ! pack_data I Data type holding configure ! information and dynamic memory. ! in_year I Year ! in_doy I Day of the year ! ! Output: ! Name Type Description ! --------------------------------------------------- ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! ! System Calls: ! None ! ! History: ! 2014-03-15 Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS ! 2015-05-15 Added extra attributes holding the mean ! output variabl values. ! 2016-02-15 Correct the unit of ET is mm day-1 ! all other fluxes are mJ m-2 day-1 !=============================================================== SUBROUTINE pack_write_netcdf(pack_data, in_year, in_doy, & return_status) ! ---------- ! Module use ! ---------- USE type_kinds USE GETD_constants_mod USE GETD_log_mod USE netcdf ! --------------------------- ! Disable all implicit typing ! --------------------------- IMPLICIT NONE ! --------- ! Arguments ! --------- TYPE(PackDataType), INTENT(in) :: pack_data INTEGER(Long), INTENT(in) :: in_year INTEGER(Long), INTENT(in) :: in_doy INTEGER(Long), INTENT(out) :: return_status ! Local parameters used for NETCDF information usage ! It's good practice for each variable to carry a "units" attribute. ! Note, the ET needs to be converted to mm day -1 ! before this process ! http://www.fao.org/docrep/x0490e/x0490e0i.htm ! equivalent radiation in megajoules per square ! metre per day (MJ m-2 day-1) ! 1 MJ m-2 day-1 = 0.408 mm day-1 CHARACTER (len = *), PARAMETER :: MEAN = "mean value" CHARACTER (len = *), PARAMETER :: UNITS = "units" CHARACTER (len = *), PARAMETER :: ET_UNITS = "mm_day-1" CHARACTER (len = *), PARAMETER :: FLUX_UNITS = "mJ_m-2_day-1" CHARACTER (len = *), PARAMETER :: ESI_UNITS = "none" CHARACTER (len = *), PARAMETER :: LAT_UNITS = "degrees_north" CHARACTER (len = *), PARAMETER :: LON_UNITS = "degrees_east" CHARACTER (len = *), PARAMETER :: SCALING = "scaling_factor" INTEGER(Short),PARAMETER :: sfactor = 10000 ! ---------------- ! Local variables ! --------------- INTEGER :: nc4_fileid INTEGER :: ncid ! ID for the NC file INTEGER :: dimids(2) ! ID for the dimensions INTEGER :: lon_dimid, lat_dimid INTEGER :: lon_varid, lat_varid INTEGER :: et_varid, et_qc_varid INTEGER :: gday_varid, gday_qc_varid INTEGER :: hday_varid, hday_qc_varid INTEGER :: sdday_varid, sdday_qc_varid INTEGER :: snetday_varid, snetday_qc_varid INTEGER :: lwdnday_varid, lwdnday_qc_varid INTEGER :: lwupday_varid, lwupday_qc_varid INTEGER :: esi2w_varid, esi2w_qc_varid INTEGER :: esi4w_varid, esi4w_qc_varid INTEGER :: esi8w_varid, esi8w_qc_varid INTEGER :: esi12w_varid, esi12w_qc_varid INTEGER :: col_num, row_num INTEGER :: i, j, istat INTEGER :: nc_fill ! Data matrix to write to the NETCDF file REAL(Single), DIMENSION(:), ALLOCATABLE :: lat, lon INTEGER(NF90_INT), DIMENSION(:,:), ALLOCATABLE :: data_out INTEGER(NF90_INT), DIMENSION(:,:), ALLOCATABLE :: qc_out CHARACTER(LONG_STR) :: file_name CHARACTER(LONG_STR) :: tmp_str CHARACTER(len=9) :: yyyydoy_str CHARACTER(len=8) :: log_date CHARACTER(len=10) :: log_time CHARACTER(len=5) :: log_zone ! Locate the file with the path and time information WRITE(yyyydoy_str,'(a1,i4.4, i3.3, a1)')'_',in_year, in_doy, '.' CALL DATE_AND_TIME(date=log_date,time=log_time,zone = log_zone) WRITE(tmp_str,'(a8,a1,a2,a1,a2,a1)') log_date,':', & log_time(1:2),'h', log_time(3:4),'m' ! Set the name of the output NETCDF file with output path information ! and time information write(*,*)'Processing time: ', trim(tmp_str) WRITE(file_name,'(a,a1,a,a9, a2)')TRIM(pack_data%out_path), & '/',TRIM(pack_data%out_netcdf_file), yyyydoy_str, 'nc' ! Always check the return code of every netCDF function call. In ! this example program, wrapping netCDF calls with "call check()" ! makes sure that any return which is not equal to nf90_noerr (0) ! will print a netCDF error message and exit. ! Create the netCDF file. The nf90_hdf5 parameter tells netCDF to ! overwrite this file, if it already exists. CALL check( nf90_create(TRIM(file_name), NF90_CLOBBER, ncid) ) ! Define the dimensions. NetCDF will hand back an ID for each. CALL check( nf90_def_dim(ncid, "Longitude", & pack_data%in_col_num, lon_dimid)) CALL check( nf90_def_dim(ncid, "Latitude", & pack_data%in_row_num, lat_dimid)) ! Create the lon and lat informaiton using input domain boundary ALLOCATE(lon(pack_data%in_col_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate lon data error!' return_status = FAILURE RETURN END IF DO i = 1, pack_data%in_col_num lon(i) = pack_data%in_west_lon + & pack_data%in_lon_resolution * i - 0.5 END DO ! Lat ALLOCATE(lat(pack_data%in_row_num), stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,*)'Allocate lat error!' return_status = FAILURE RETURN END IF DO i = 1, pack_data%in_row_num lat(i) = pack_data%in_south_lat + & pack_data%in_lat_resolution*i - 0.5 END DO ! The dimids array is used to pass the IDs of the dimensions of ! the variables. Note that in fortran arrays are stored in ! column-major format. dimids = (/ lon_dimid, lat_dimid /) ! Define the netCDF variables. The dimids array is used to pass the ! dimids of the dimensions of the netCDF variables. CALL check( nf90_def_var(ncid, "Longitude", NF90_REAL, & lon_dimid, lon_varid)) CALL check( nf90_def_var(ncid, "Latitude", NF90_REAL, & lat_dimid, lat_varid)) ! Define the variable. The type of the variable in this case is ! NF90_INT (4-byte integer). ALLOCATE(data_out(pack_data%in_col_num, pack_data%in_row_num), & stat = istat) if ( istat /= SUCCESS ) then WRITE(GETD_logunit,*)'Allocate NETCDF output DATA error!' return_status = FAILURE RETURN endif ALLOCATE(qc_out(pack_data%in_col_num, pack_data%in_row_num), & stat = istat) if ( istat /= SUCCESS ) then WRITE(GETD_logunit,*)'Allocate NETCDF output QC error!' return_status = FAILURE RETURN endif ! Define the variables to write to the NETCDF files CALL check( nf90_def_var(ncid, "ET", NF90_INT, & dimids, et_varid) ) CALL check( nf90_def_var(ncid, "ET_QC", NF90_INT, & dimids, et_qc_varid) ) CALL check( nf90_def_var(ncid, "GDAY", NF90_INT, & dimids, gday_varid) ) CALL check( nf90_def_var(ncid, "GDAY_QC", NF90_INT, & dimids, gday_qc_varid) ) CALL check( nf90_def_var(ncid, "HDAY", NF90_INT, & dimids, hday_varid) ) CALL check( nf90_def_var(ncid, "HDAY_QC", NF90_INT, & dimids, hday_qc_varid) ) CALL check( nf90_def_var(ncid, "SDDAY", NF90_INT, & dimids, sdday_varid) ) CALL check( nf90_def_var(ncid, "SDDAY_QC", NF90_INT, & dimids, sdday_qc_varid) ) CALL check( nf90_def_var(ncid, "SNETDAY", NF90_INT, & dimids, snetday_varid) ) CALL check( nf90_def_var(ncid, "SNETDAY_QC", NF90_INT, & dimids, snetday_qc_varid) ) CALL check( nf90_def_var(ncid, "LWDNDAY", NF90_INT, & dimids, lwdnday_varid) ) CALL check( nf90_def_var(ncid, "LWDNDAY_QC", NF90_INT, & dimids, lwdnday_qc_varid) ) CALL check( nf90_def_var(ncid, "LWUPDAY", NF90_INT, & dimids, lwupday_varid) ) CALL check( nf90_def_var(ncid, "LWUPDAY_QC", NF90_INT, & dimids, lwupday_qc_varid) ) CALL check( nf90_def_var(ncid, "ESI_2_WEEK", NF90_INT, & dimids, esi2w_varid) ) CALL check( nf90_def_var(ncid, "ESI_2_WEEK_QC", NF90_INT, & dimids, esi2w_qc_varid) ) CALL check( nf90_def_var(ncid, "ESI_4_WEEK", NF90_INT, & dimids, esi4w_varid) ) CALL check( nf90_def_var(ncid, "ESI_4_WEEK_QC", NF90_INT, & dimids, esi4w_qc_varid) ) CALL check( nf90_def_var(ncid, "ESI_8_WEEK", NF90_INT, & dimids, esi8w_varid) ) CALL check( nf90_def_var(ncid, "ESI_8_WEEK_QC", NF90_INT, & dimids, esi8w_qc_varid) ) CALL check( nf90_def_var(ncid, "ESI_12_WEEK", NF90_INT, & dimids, esi12w_varid) ) CALL check( nf90_def_var(ncid, "ESI_12_WEEK_QC", NF90_INT,& dimids, esi12w_qc_varid) ) ! Assign global attributes to the file ! Put the date information in the attribute CALL check( nf90_put_att(ncid, NF90_GLOBAL,"TITLE","GETD product" )) WRITE(yyyydoy_str,'(i4.4, i3.3)')in_year, in_doy CALL check( nf90_put_att(ncid, NF90_GLOBAL,"DATE",yyyydoy_str )) CALL check( nf90_put_att(ncid, NF90_GLOBAL,"PROCESSING TIME",tmp_str)) ! Assign units attributes to coordinate var data. This attaches a ! text attribute to each of the coordinate variables, containing the ! units. CALL check( nf90_put_att(ncid, lat_varid, UNITS, LAT_UNITS) ) CALL check( nf90_put_att(ncid, lat_varid, "_FillValue", -9999.) ) CALL check( nf90_put_att(ncid, lon_varid, UNITS, LON_UNITS) ) CALL check( nf90_put_att(ncid, lon_varid, "_FillValue", -9999.) ) ! Assign units attributes to the output ! variables in the NETCDF file. nc_fill = pack_data%in_fill_value * sfactor CALL check( nf90_put_att(ncid, et_varid, UNITS, ET_UNITS) ) CALL check( nf90_put_att(ncid, et_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, et_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, et_varid, MEAN, pack_data%et_mean) ) ! Fluxes CALL check( nf90_put_att(ncid, gday_varid, UNITS, FLUX_UNITS) ) CALL check( nf90_put_att(ncid, gday_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, gday_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, gday_varid, & MEAN, pack_data%gday_mean) ) CALL check( nf90_put_att(ncid, hday_varid, UNITS, FLUX_UNITS) ) CALL check( nf90_put_att(ncid, hday_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, hday_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, hday_varid, & MEAN, pack_data%hday_mean) ) CALL check( nf90_put_att(ncid, sdday_varid, UNITS, FLUX_UNITS) ) CALL check( nf90_put_att(ncid, sdday_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, sdday_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, sdday_varid, & MEAN, pack_data%sdday_mean) ) CALL check( nf90_put_att(ncid, snetday_varid, UNITS, FLUX_UNITS) ) CALL check( nf90_put_att(ncid, snetday_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, snetday_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, snetday_varid, & MEAN, pack_data%snetday_mean) ) CALL check( nf90_put_att(ncid, lwdnday_varid, UNITS, FLUX_UNITS) ) CALL check( nf90_put_att(ncid, lwdnday_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, lwdnday_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, lwdnday_varid, & MEAN, pack_data%lwdnday_mean) ) CALL check( nf90_put_att(ncid, lwupday_varid, UNITS, FLUX_UNITS) ) CALL check( nf90_put_att(ncid, lwupday_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, lwupday_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, lwupday_varid, & MEAN, pack_data%lwupday_mean) ) ! ESI results CALL check( nf90_put_att(ncid, esi2w_varid, UNITS, ESI_UNITS) ) CALL check( nf90_put_att(ncid, esi2w_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, esi2w_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, esi2w_varid, & MEAN, pack_data%esi_2week_mean)) CALL check( nf90_put_att(ncid, esi4w_varid, UNITS, ESI_UNITS) ) CALL check( nf90_put_att(ncid, esi4w_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, esi4w_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, esi4w_varid, & MEAN, pack_data%esi_4week_mean)) CALL check( nf90_put_att(ncid, esi8w_varid, UNITS, ESI_UNITS) ) CALL check( nf90_put_att(ncid, esi8w_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, esi8w_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, esi8w_varid, & MEAN, pack_data%esi_8week_mean)) CALL check( nf90_put_att(ncid, esi12w_varid, UNITS, ESI_UNITS) ) CALL check( nf90_put_att(ncid, esi12w_varid, SCALING, sfactor) ) CALL check( nf90_put_att(ncid, esi12w_varid, "_FillValue", nc_fill) ) CALL check( nf90_put_att(ncid, esi12w_varid, & MEAN, pack_data%esi_12week_mean)) ! End define mode. This tells netCDF we are done defining metadata. CALL check( nf90_enddef(ncid) ) !WRITE(GETD_logunit,*)'Done with define dim and att' WRITE(GETD_logunit,*)'Done with define dim and att' ! Write the actual data to the file. Although netCDF supports ! reading and writing subsets of data, in this case we write all the ! data in one operation. CALL check( nf90_put_var(ncid, lat_varid, lat) ) CALL check( nf90_put_var(ncid, lon_varid, lon) ) ! Convert the input floating data into NC_INT format ! Whole matrix operation ! Daily fluxes, ET, G, H, SD, SNET, LWDN, LWUP data_out = int(pack_data%in_et_data * sfactor) qc_out = int(pack_data%in_et_qc) CALL check( nf90_put_var(ncid, et_varid, data_out) ) CALL check( nf90_put_var(ncid, et_qc_varid, qc_out) ) data_out = int(pack_data%in_gday_data * sfactor) qc_out = int(pack_data%in_gday_qc) CALL check( nf90_put_var(ncid, gday_varid, data_out) ) CALL check( nf90_put_var(ncid, gday_qc_varid, qc_out) ) data_out = int(pack_data%in_hday_data * sfactor) qc_out = int(pack_data%in_hday_qc) CALL check( nf90_put_var(ncid, hday_varid, data_out) ) CALL check( nf90_put_var(ncid, hday_qc_varid, qc_out) ) data_out = int(pack_data%in_sdday_data * sfactor) qc_out = int(pack_data%in_sdday_qc) CALL check( nf90_put_var(ncid, sdday_varid, data_out) ) CALL check( nf90_put_var(ncid, sdday_qc_varid, qc_out) ) data_out = int(pack_data%in_snetday_data * sfactor) qc_out = int(pack_data%in_snetday_qc) CALL check( nf90_put_var(ncid, snetday_varid, data_out) ) CALL check( nf90_put_var(ncid, snetday_qc_varid, qc_out) ) data_out = int(pack_data%in_lwdnday_data * sfactor) qc_out = int(pack_data%in_lwdnday_qc) CALL check( nf90_put_var(ncid, lwdnday_varid, data_out) ) CALL check( nf90_put_var(ncid, lwdnday_qc_varid, qc_out) ) data_out = int(pack_data%in_lwupday_data * sfactor) qc_out = int(pack_data%in_lwupday_qc) CALL check( nf90_put_var(ncid, lwupday_varid, data_out) ) CALL check( nf90_put_var(ncid, lwupday_qc_varid, qc_out) ) ! ESI 2, 4, 8, 12 weeks data_out = int(pack_data%in_esi_2week * sfactor) qc_out = int(pack_data%in_esi_2week_qc) CALL check( nf90_put_var(ncid, esi2w_varid, data_out) ) CALL check( nf90_put_var(ncid, esi2w_qc_varid, qc_out)) data_out = int(pack_data%in_esi_4week * sfactor) qc_out = int(pack_data%in_esi_4week_qc) CALL check( nf90_put_var(ncid, esi4w_varid, data_out) ) CALL check( nf90_put_var(ncid, esi4w_qc_varid, qc_out) ) data_out = int(pack_data%in_esi_8week * sfactor) qc_out = int(pack_data%in_esi_8week_qc) CALL check( nf90_put_var(ncid, esi8w_varid, data_out) ) CALL check( nf90_put_var(ncid, esi8w_qc_varid, qc_out)) data_out = int(pack_data%in_esi_12week * sfactor) qc_out = int(pack_data%in_esi_12week_qc) CALL check( nf90_put_var(ncid, esi12w_varid, data_out) ) write(GETD_logunit,*)"Check esi12w_qc_varid" CALL check( nf90_put_var(ncid, esi12w_qc_varid, qc_out) ) write(GETD_logunit,*)"Check esi12w_qc_varid2" ! Close the file. This frees up any internal netCDF resources ! associated with the file, and flushes any buffers. CALL check( nf90_close(ncid) ) if ( allocated(lat) ) then DEALLOCATE(lat, stat = istat) endif if ( allocated(lon) ) then DEALLOCATE(lon, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate lon error!' return_status = FAILURE END IF endif if ( allocated(data_out) ) then DEALLOCATE(data_out, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate DATA out error!' return_status = FAILURE END IF endif if ( allocated(qc_out) ) then DEALLOCATE(qc_out, stat = istat) IF ( istat /= SUCCESS ) THEN WRITE(GETD_logunit,'(a)') 'Deallocate QC out error!' return_status = FAILURE ENDIF endif WRITE(GETD_logunit, *) & "*** SUCCESS writing output ", TRIM(file_name), ' !' return_status = SUCCESS END SUBROUTINE pack_write_netcdf !=============================================================== ! Name: check ! ! Type: Subroutine ! ! Function: ! Check NETCDF io modules and return error code. ! Description: ! This subroutine is used to replace the check subroutine ! in the NETCDF example file. ! ! Files Needed: ! - ! Modules Needed: ! - type_kinds ! - GETD_constants_mod ! - GETD_log_mod ! - netcdf ! ! Subroutines Contained: ! N/A ! ! Calling Sequence: ! CALL check(status, return_status) ! Input: ! Name Type Description ! --------------------------------------------------- ! status I Input status of NETCDF subroutines ! ! Output: ! Name Type Description ! --------------------------------------------------- ! return_status O Flag, 0 - SUCCESS, 1 - FAILURE ! ! System Calls: ! None ! ! History: !2014-04-15 Modified by Zhengpeng Li (UMD ESSIC) NOAA/NESDIS/STAR/CICS ! Modified from NETCDF example F90 codes !=============================================================== SUBROUTINE check(status) ! ---------- ! Module use ! ---------- USE type_kinds USE GETD_constants_mod USE GETD_log_mod USE netcdf ! --------------------------- ! Disable all implicit typing ! --------------------------- IMPLICIT NONE INTEGER, INTENT ( in) :: status IF(status /= nf90_noerr) THEN WRITE(GETD_logunit,*) TRIM(nf90_strerror(status)) STOP END IF END SUBROUTINE check !---------------------------------------------------------- END MODULE pack_outputs_mod