diff --git a/bmi/bmi_noahowp.f90 b/bmi/bmi_noahowp.f90 index dfbeec87..033e342d 100644 --- a/bmi/bmi_noahowp.f90 +++ b/bmi/bmi_noahowp.f90 @@ -196,12 +196,14 @@ function noahowp_initialize(this, config_file) result (bmi_status) character (len=*), intent(in) :: config_file integer :: bmi_status + bmi_status = BMI_SUCCESS if (len(config_file) > 0) then call initialize_from_file(this%model, config_file) else !call initialize_from_defaults(this%model) end if - bmi_status = BMI_SUCCESS + bmi_status = this%model%error%error_flag + end function noahowp_initialize ! BMI finalizer. @@ -267,9 +269,11 @@ end function noahowp_time_units function noahowp_update(this) result (bmi_status) class (bmi_noahowp), intent(inout) :: this integer :: bmi_status + bmi_status = BMI_SUCCESS call advance_in_time(this%model) - bmi_status = BMI_SUCCESS + bmi_status = this%model%error%error_flag + end function noahowp_update ! Advance the model until the given time. diff --git a/driver/AsciiReadModule.f90 b/driver/AsciiReadModule.f90 index 57df6d6a..850207ea 100644 --- a/driver/AsciiReadModule.f90 +++ b/driver/AsciiReadModule.f90 @@ -1,8 +1,11 @@ module AsciiReadModule use UtilitiesModule + use ErrorCheckModule implicit none + character(len=*), PARAMETER :: moduleName='AsciiReadModule' + private :: moduleName contains @@ -11,6 +14,7 @@ subroutine open_forcing_file(filename) implicit none character*256, intent(in) :: filename + character(len=*), PARAMETER :: subroutineName = 'open_forcing_file' !--------------------------------------------------------------------- ! local variables @@ -22,17 +26,19 @@ subroutine open_forcing_file(filename) ! Check if the specified file exists inquire(file = trim(filename), exist = lexist) if (.not. lexist) then - write(*,'(/," ***** Problem *****")') - write(*,'(" ***** File ''", A, "'' does not exist.")') trim(filename) - write(*,'(" ***** Check the forcing file specified as a command-line argument",/)') - stop ": ERROR EXIT" + error_flag = NOM_FAILURE + write(error_string,'(A,A,A)') 'AsciiReadModule'//' - '//subroutineName//'(): File: ',trim(filename), ' does not exist. Check the forcing file specified as a command-line argument.' + call log_message(error_flag, error_string) + return endif ! Open the forcing file open(10, file = trim(filename), form = 'formatted', action = 'read', iostat = ierr) if (ierr /= 0) then - write(*,'("Problem opening file ''", A, "''")') trim(filename) - stop ": ERROR EXIT" + error_flag = NOM_FAILURE + write(error_string,'(A,A,A)') 'AsciiReadModule'//' - '//subroutineName//'(): Problem opening file: ',trim(filename) + call log_message(error_flag, error_string) + return endif end subroutine open_forcing_file @@ -110,6 +116,7 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & real, parameter :: eps = 0.622 character(len=1024) :: string + character(len=*), PARAMETER :: subroutineName = 'read_forcing_text' ! Flag to tell us whether this is the first time this subroutine is called, in which case ! we need to seek forward to the data. @@ -166,10 +173,11 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & return endif - if (ierr /= 0) then - write(*,'("Error reading from data file.")') - ierr = 2 - return + if (ierr /= 0) then + error_flag = NOM_FAILURE + write(error_string,'(A)') 'AsciiReadModule'//' - '//subroutineName//'(): Error reading from data file.' + call log_message(error_flag, error_string) + return endif write(readdate,'(I4.4,4I2.2)') year, month, day, hour, minute @@ -185,7 +193,10 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & before = fdata ( readdate, read_windspeed, read_winddir, read_temperature, read_humidity, read_pressure, read_swrad, read_lwrad, read_rain ) cycle READLOOP else - stop "Logic problem" + error_flag = NOM_FAILURE + write(error_string,'(A)') 'AsciiReadModule'//' - '//subroutineName//'(): Logic problem.' + call log_message(error_flag, error_string) + return endif enddo READLOOP @@ -218,6 +229,9 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & call geth_idts(nowdate, before%readdate, idts) call geth_idts(after%readdate, before%readdate, idts2) + if (error_flag == NOM_FAILURE) then + return + endif if (idts2*60 /= forcing_timestep) then print*, 'forcing_timestep = ', forcing_timestep @@ -226,7 +240,10 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & print*, 'idts = ', idts print*,' after%readdate = ', after%readdate print*, 'idts2 = ', idts2 - stop "IDTS PROBLEM" + error_flag = NOM_FAILURE + write(error_string,'(A)') 'AsciiReadModule'//' - '//subroutineName//'(): IDTS PROBLEM.' + call log_message(error_flag, error_string) + return endif fraction = real(idts2-idts)/real(idts2) @@ -250,8 +267,10 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & rhf = rhf * 1.E-2 else - print*, 'nowdate = "'//nowdate//'"' - stop "Problem in the logic of read_forcing_text." + error_flag = NOM_FAILURE + write(error_string,'(A,A,A)') 'AsciiReadModule'//' - '//subroutineName//'(): date: ', nowdate, '. Problem in the logic of read_forcing_text.' + call log_message(error_flag, error_string) + return endif ! Below commented out KSJ 2021-06-09 diff --git a/driver/NoahModularDriver.f90 b/driver/NoahModularDriver.f90 index a86ef930..02562169 100644 --- a/driver/NoahModularDriver.f90 +++ b/driver/NoahModularDriver.f90 @@ -29,6 +29,14 @@ program model_driver print*, "Initializing..." call get_command_argument(1, arg) status = m%initialize(arg) + if (status == BMI_FAILURE) then +#ifdef NGEN_ACTIVE + return status ! if NGEN +#else + print*, "Stopping program." + stop +#endif + end if !--------------------------------------------------------------------- ! Run the model with BMI @@ -43,6 +51,14 @@ program model_driver print*, "Running..." do while (current_time < end_time) status = m%update() ! run the model one time step + if (status == BMI_FAILURE) then +#ifdef NGEN_ACTIVE + return status ! if NGEN +#else + print*, "Stopping program." + stop +#endif + end if status = m%get_current_time(current_time) ! update current_time end do diff --git a/err_flag_info.txt b/err_flag_info.txt new file mode 100644 index 00000000..58ccdfa7 --- /dev/null +++ b/err_flag_info.txt @@ -0,0 +1,20 @@ +./ParametersRead.f90: SUBROUTINE read_rad_parameters(param_dir, noahowp_table, error_flag) +./ParametersRead.f90: subroutine read_global_parameters(param_dir, noahowp_table, error_flag) +./ParametersRead.f90: SUBROUTINE read_crop_parameters(param_dir, noahowp_table, error_flag) +./ParametersRead.f90: SUBROUTINE read_irrigation_parameters(param_dir, noahowp_table, error_flag) +./ParametersRead.f90: SUBROUTINE read_tiledrain_parameters(param_dir, noahowp_table, error_flag) +./ParametersRead.f90: SUBROUTINE read_optional_parameters(param_dir, noahowp_table, error_flag) +./RunModule.f90: call namelist%ReadNamelist(config_filename,domain%error_flag) +./RunModule.f90: call parameters%paramRead(namelist, model%domain%error_flag) +./RunModule.f90: call get_utime_list (domain%start_datetime, domain%end_datetime, domain%dt, domain%sim_datetimes, domain%error_flag) ! makes unix-time list for desired records (end-of-timestep) +./RunModule.f90: call open_forcing_file(namelist%forcing_filename, model%domain%error_flag) +./NamelistRead.f90: subroutine ReadNamelist(this, namelist_file, error_flag) +./UtilitiesModule.f90: subroutine geth_idts (newdate, olddate, idt, error_flag) +./UtilitiesModule.f90: call geth_idts(nowdate(1:10), nowdate(1:4)//"-01-01", iday, error_flag) +./DateTimeUtilsModule.f90: subroutine get_utime_list (start_datetime, end_datetime, dt, times, error_flag) +./ParametersType.f90: subroutine paramRead(this, namelist, error_flag) +./ParametersType.f90: call read_soil_parameters(namelist%parameter_dir, namelist%soil_table, namelist%general_table, namelist%soil_class_name, error_flag) +./ParametersType.f90: call read_veg_parameters(namelist%parameter_dir, namelist%noahowp_table, namelist%veg_class_name, error_flag) +./ParametersType.f90: call read_rad_parameters(namelist%parameter_dir, namelist%noahowp_table, error_flag) +./ParametersType.f90: call read_global_parameters(namelist%parameter_dir, namelist%noahowp_table, error_flag) +./EnergyModule.f90: call log_message(domain%error_flag, trim(error_string)) diff --git a/run/Makefile b/run/Makefile index ce0caeba..de17c55c 100644 --- a/run/Makefile +++ b/run/Makefile @@ -7,6 +7,7 @@ include ../user_build_options OBJS = \ ../src/ErrorCheckModule.o \ + ../src/ErrorType.o \ ../src/NamelistRead.o \ ../src/ParametersRead.o \ ../src/LevelsType.o \ diff --git a/src/DateTimeUtilsModule.f90 b/src/DateTimeUtilsModule.f90 index f394b6c8..0fa92764 100644 --- a/src/DateTimeUtilsModule.f90 +++ b/src/DateTimeUtilsModule.f90 @@ -3,7 +3,11 @@ module DateTimeUtilsModule + use ErrorCheckModule + implicit none + character(len=*), PARAMETER :: moduleName='DateTimeUtilsModule' + private :: moduleName public integer, parameter :: kr4 = selected_real_kind (6, 37)! single precision real @@ -61,42 +65,42 @@ module DateTimeUtilsModule !********************************************************************** - subroutine parse (str, delims, args, nargs) +! subroutine parse (str, delims, args, nargs) ! Parses the string 'str' into arguments args(1), ..., args(nargs) based on ! the delimiters contained in the string 'delims'. Preceding a delimiter in ! 'str' by a backslash (\) makes this particular instance not a delimiter. ! The integer output variable nargs contains the number of arguments found. - character (len=*) :: str, delims - character (len=len_trim(str)) :: strsav - character (len=*), dimension (:) :: args - integer :: i, k, na, nargs, lenstr - - strsav = str - call compact (str) - na = size (args) - do i = 1, na - args (i) = ' ' - end do - nargs = 0 - lenstr = len_trim (str) - if (lenstr == 0) return - k = 0 - - do - if (len_trim(str) == 0) exit - nargs = nargs + 1 - if(nargs .gt. size(args)) then - print *,'Number of predictors larger than expected, check nPredict' - stop - end if - call split (str, delims, args(nargs)) - call removebksl (args(nargs)) - end do - str = strsav - - end subroutine parse +! character (len=*) :: str, delims +! character (len=len_trim(str)) :: strsav +! character (len=*), dimension (:) :: args +! integer :: i, k, na, nargs, lenstr + +! strsav = str +! call compact (str) +! na = size (args) +! do i = 1, na +! args (i) = ' ' +! end do +! nargs = 0 +! lenstr = len_trim (str) +! if (lenstr == 0) return +! k = 0 + +! do +! if (len_trim(str) == 0) exit +! nargs = nargs + 1 +! if(nargs .gt. size(args)) then +! print *,'Number of predictors larger than expected, check nPredict' +! stop +! end if +! call split (str, delims, args(nargs)) +! call removebksl (args(nargs)) +! end do +! str = strsav + +! end subroutine parse !********************************************************************** @@ -879,14 +883,16 @@ double precision function date_to_unix (date) character (len=*), intent (in) :: date double precision :: u_day, i_day, days integer :: sec, min, hour, day, month, year, error + character(len=*), PARAMETER :: subroutineName = 'date_to_unix' call parse_date (date, year, month, day, hour, min, sec, error) if (error /= 0) then + error_flag = NOM_FAILURE date_to_unix = -9999.99 - print*, 'error in date_to_unix -- date, year, month, day, hour, min, sec, error:' - print*, date, year, month, day, hour, min, sec, error - stop !return + write(error_string,'(A,A,A,I4,A,I4,A,I4,A,I4,A,I4,A,I4,A,I4)') moduleName//" - "//subroutineName//"(): date: ",date," year: ",year," month: ",month," day: ",day," hour: ",hour," min: ",min," sec: ",sec, " Error: ",error + call log_message(error_flag, error_string) + return end if u_day = julian_date (1, 1, 1970) @@ -970,12 +976,14 @@ subroutine get_utime_list (start_datetime, end_datetime, dt, times) !local integer :: t, ntimes real*8 :: utime + character(len=*), PARAMETER :: subroutineName = 'get_utime_list' if(abs(mod(end_datetime - start_datetime, dt)) > 1e-5) then - print*, 'start and end datetimes are not an even multiple of dt -- check dates in namelist' - print*, 'end_datetime, start_datetime, dt, mod:', end_datetime, start_datetime, dt, mod(end_datetime-start_datetime, dt) - stop - end if + error_flag = NOM_FAILURE + write(error_string,'(A,G8.3,A,G8.3,A,G8.3,A,G8.3)') moduleName//" - "//subroutineName//"(): start and end datetimes are not an even multiple of dt -- check dates in namelist: end_datetime: ",end_datetime," start_datetime: ",start_datetime," dt: ",dt," mod: ", mod(end_datetime-start_datetime, dt) + call log_message(error_flag, error_string) + return + endif ntimes = int((end_datetime - start_datetime)/dt) + 1 allocate (times(ntimes)) diff --git a/src/DomainType.f90 b/src/DomainType.f90 index 12f4d2b4..b57edad4 100644 --- a/src/DomainType.f90 +++ b/src/DomainType.f90 @@ -2,6 +2,7 @@ module DomainType use NamelistRead, only: namelist_type use DateTimeUtilsModule +use ErrorCheckModule implicit none save @@ -31,6 +32,7 @@ module DomainType integer :: croptype ! crop type integer :: isltyp ! soil type integer :: IST ! surface type 1-soil; 2-lake + real, allocatable, dimension(:) :: zsoil ! depth of layer-bottom from soil surface real, allocatable, dimension(:) :: dzsnso ! snow/soil layer thickness [m] real, allocatable, dimension(:) :: zsnso ! depth of snow/soil layer-bottom @@ -117,7 +119,17 @@ subroutine InitTransfer(this, namelist) this%isltyp = namelist%isltyp this%IST = namelist%sfctyp this%start_datetime = date_to_unix(namelist%startdate) ! returns seconds-since-1970-01-01 + if (this%start_datetime < 0) then + error_flag = NOM_FAILURE + error_string = 'DomainType - InitTransfer(): Invalid start time' + return + endif this%end_datetime = date_to_unix(namelist%enddate) + if (this%end_datetime < 0) then + error_flag = NOM_FAILURE + error_string = 'DomainType - InitTransfer(): Invalid end time' + return + endif end subroutine InitTransfer diff --git a/src/EnergyModule.f90 b/src/EnergyModule.f90 index 7eff19a3..6fdc46a7 100644 --- a/src/EnergyModule.f90 +++ b/src/EnergyModule.f90 @@ -2,6 +2,7 @@ module EnergyModule use LevelsType use DomainType + use ErrorCheckModule use OptionsType use ParametersType use WaterType @@ -13,6 +14,8 @@ module EnergyModule use EtFluxModule use SnowSoilTempModule implicit none + character(len=*), PARAMETER :: moduleName='EnergyModule' + private :: moduleName contains @@ -45,6 +48,7 @@ SUBROUTINE EnergyMain (domain, levels, options, parameters, forcing, energy, wat REAL :: D_RSURF ! Reduced vapor diffusivity in soil for computing RSURF (SZ09) REAL :: FIRE !emitted IR (w/m2) + CHARACTER(len=*), PARAMETER :: subroutineName = 'EnergyMain' !--------------------------------------------------------------------- ! Initialize the the fluxes from the vegetated fraction @@ -300,12 +304,14 @@ SUBROUTINE EnergyMain (domain, levels, options, parameters, forcing, energy, wat FIRE = forcing%LWDN + energy%FIRA IF(FIRE <=0.) THEN - WRITE(*,*) 'emitted longwave <0; skin T may be wrong due to inconsistent' - WRITE(*,*) 'input of SHDFAC with LAI' - WRITE(*,*) domain%ILOC, domain%JLOC, 'SHDFAC=',parameters%FVEG,'parameters%VAI=',parameters%VAI,'TV=',energy%TV,'TG=',energy%TG - WRITE(*,*) 'LWDN=',forcing%LWDN,'energy%FIRA=',energy%FIRA,'water%SNOWH=',water%SNOWH - WRITE(*,*) 'Exiting ...' - STOP + error_flag = NOM_FAILURE + write(error_string,101) moduleName//' - '//subroutineName//'(): emitted longwave <0; skin T & + may be wrong due to inconsistent input of SHDFAC with LAI. ILOC=', & + domain%ILOC, ', JLOC=',domain%JLOC, ', SHDFAC=',parameters%FVEG,', & + parameters%VAI=',parameters%VAI,', TV=',energy%TV,', TG=',energy%TG +101 format(A,I10,A,I10,A,F8.3,A,F8.3,A,F8.3,A,F8.3) + call log_message(error_flag, trim(error_string)) + RETURN END IF ! Compute a net emissivity diff --git a/src/ErrorCheckModule.f90 b/src/ErrorCheckModule.f90 index f3306965..7032a361 100644 --- a/src/ErrorCheckModule.f90 +++ b/src/ErrorCheckModule.f90 @@ -1,36 +1,58 @@ module ErrorCheckModule - ! General error checking routins - + ! General error checking routines implicit none - private - public:: sys_abort - public:: is_within_bound + integer, parameter, public :: NOM_SUCCESS = 0 + integer, parameter, public :: NOM_FAILURE = 1 + integer, parameter, public :: NOM_MESSAGE = 2 + + integer :: error_flag + character(len=256) :: error_string interface is_within_bound module procedure is_within_bound_int module procedure is_within_bound_real end interface + contains - subroutine sys_abort(err, message) + subroutine log_message(err, message) - ! terminate the program if error is detected (err is non-zero) + ! log information, typically an error implicit none integer, intent(in) :: err ! error code - character(*), intent(in) :: message ! error message + character(*), intent(in) :: message ! message - if(err/=0)then - write(*, '(A)') 'FATAL ERROR: '//trim(message) + ! If error, write the error. If message, write message unless NGEN_QUIET + if(err==NOM_FAILURE)then + write(*, '(A,I2,A)') ' Error Code: ', err, ', Message: '//trim(message) call flush(6) - stop endif +#ifndef NGEN_QUIET + if(err==NOM_MESSAGE)then + write(*, '(A,I2,A)') ' Error Code: ', err, ', Message: '//trim(message) + call flush(6) + endif +#endif + + end subroutine log_message + +! Save state of error_flag and error_string to members of another object. + subroutine save_error_state(err, message) + implicit none + + integer, intent(out) :: err ! error code + character(*), intent(out) :: message ! message + + err = error_flag + message = error_string + + end subroutine save_error_state - end subroutine sys_abort function is_within_bound_int(var, lower_bound, upper_bound) result(withinbound) diff --git a/src/ErrorType.f90 b/src/ErrorType.f90 new file mode 100644 index 00000000..3694fe39 --- /dev/null +++ b/src/ErrorType.f90 @@ -0,0 +1,44 @@ +module ErrorType + +use ErrorCheckModule + +implicit none +save +private + +type, public :: error_type + + integer :: error_flag ! error flag + character(len=256) :: error_string ! error string + + contains + + procedure, public :: Init + procedure, private :: InitDefault + +end type error_type + +contains + + subroutine Init(this) + + class(error_type) :: this + + call this%InitDefault() + + end subroutine Init + + + subroutine InitDefault(this) + + class(error_type) :: this + + error_flag = NOM_SUCCESS ! ModuleErrorCheck variable + error_string = 'EMPTY' + + this%error_flag = error_flag ! ModelType variable + this%error_string = error_string + + end subroutine InitDefault + +end module ErrorType diff --git a/src/Makefile b/src/Makefile index e4cca0ea..014ac9ad 100644 --- a/src/Makefile +++ b/src/Makefile @@ -9,6 +9,7 @@ F90FLAGS := -cpp ${F90FLAGS} OBJS = ErrorCheckModule.o \ NamelistRead.o \ + ErrorType.o \ ParametersRead.o \ LevelsType.o \ DomainType.o \ @@ -105,7 +106,7 @@ EnergyModule.o: OptionsType.o LevelsType.o DomainType.o ParametersType.o EnergyT ForcingType.o WaterType.o ThermalPropertiesModule.o ShortwaveRadiationModule.o \ PrecipHeatModule.o EtFluxModule.o SnowSoilTempModule.o UtilitiesModule.o: DomainType.o ForcingType.o EnergyType.o -RunModule.o: OptionsType.o LevelsType.o DomainType.o ParametersType.o EnergyType.o \ +RunModule.o: OptionsType.o LevelsType.o DomainType.o ParametersType.o EnergyType.o ErrorType.o \ ForcingType.o WaterType.o NamelistRead.o ../driver/AsciiReadModule.o \ ../driver/OutputModule.o UtilitiesModule.o ForcingModule.o InterceptionModule.o \ EnergyModule.o WaterModule.o DateTimeUtilsModule.o diff --git a/src/NamelistRead.f90 b/src/NamelistRead.f90 index d175c4e6..cdbd2f71 100644 --- a/src/NamelistRead.f90 +++ b/src/NamelistRead.f90 @@ -1,11 +1,12 @@ module NamelistRead -use ErrorCheckModule, only: sys_abort -use ErrorCheckModule, only: is_within_bound +use ErrorCheckModule implicit none save private +character(len=*), PARAMETER :: moduleName='NamelistRead' +private :: moduleName type, public :: namelist_type @@ -168,6 +169,7 @@ subroutine ReadNamelist(this, namelist_file) integer :: integerMissing real :: realMissing character(len=12) :: stringMissing + character(len=*), PARAMETER :: subroutineName = 'ReadNamelist' ! ----------------------------------------------------------------------------------------------- ! ! initialize all namelist variables to missing values to allow for checking after namelist read ! @@ -229,46 +231,45 @@ subroutine ReadNamelist(this, namelist_file) ierr = 0 if( trim(namelist_file) .ne. '' ) then open(30, file=namelist_file, form="formatted", status='old', iostat=ierr) - if(ierr /= 0) then; write(*,'(A)') 'ERROR: user specified namelist file not found: '//trim(namelist_file); stop; end if - !print*, 'Reading namelist: ', trim(namelist_file) + if(ierr /= 0) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: user specified namelist file not found: '//trim(namelist_file); call log_message(error_flag, error_string); return; end if else open(30, file='./namelist.input', form="formatted", status='old', iostat=ierr) - if(ierr /= 0) then; write(*,'(A)') 'ERROR: default namelist file not found: ./namelist.input'; stop; end if - !print*, 'No namelist filename supplied -- attempting to read namelist.input (default)' + if(ierr /= 0) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: default namelist file not found: ./namelist.input'; call log_message(error_flag, error_string); return; end if endif read(30, timing, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if read(30, parameters, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if read(30, location, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if read(30, forcing, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if read(30, model_options, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if read(30, structure, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if !--------------------------------------------------------------------- ! Check model option validity, part 2 !--------------------------------------------------------------------- - if (.not. is_within_bound(precip_phase_option, 1, 7)) then; call sys_abort(1,'model options: precip_phase_option should be 1-7'); end if - if (.not. is_within_bound(runoff_option, 1, 8)) then; call sys_abort(1,'model options: runoff_option should be 1-8'); end if - if (.not. is_within_bound(drainage_option, 1, 8)) then; call sys_abort(1,'model options: drainage_option should be 1-8'); end if - if (.not. is_within_bound(frozen_soil_option ,1, 2)) then; call sys_abort(1,'model options: frozen_soil_option should be 1-2'); end if - if (.not. is_within_bound(dynamic_vic_option ,1, 3)) then; call sys_abort(1,'model options: dynamic_vic_option should be 1-3'); end if - if (.not. is_within_bound(dynamic_veg_option ,1, 9)) then; call sys_abort(1,'model options: dynamic_veg_option should be 1-9'); end if - if (.not. is_within_bound(snow_albedo_option ,1, 2)) then; call sys_abort(1,'model options: snow_albedo_option should be 1-2'); end if - if (.not. is_within_bound(radiative_transfer_option,1, 3)) then; call sys_abort(1,'model options: radiative_transfer_option should be 1-3'); end if - if (.not. is_within_bound(sfc_drag_coeff_option, 1, 2)) then; call sys_abort(1,'model options: sfc_drag_coeff_option should be 1-3'); end if - if (.not. is_within_bound(canopy_stom_resist_option, 1, 2)) then; call sys_abort(1,'model options: sfc_drag_coeff_option should be 1-2'); end if - if (.not. is_within_bound(snowsoil_temp_time_option, 1, 3)) then; call sys_abort(1,'model options: snowsoil_temp_time_option should be 1-3'); end if - if (.not. is_within_bound(soil_temp_boundary_option, 1, 2)) then; call sys_abort(1,'model options: soil_temp_boundary_option should be 1-2'); end if - if (.not. is_within_bound(supercooled_water_option, 1, 2)) then; call sys_abort(1,'model options: supercooled_water_option should be 1-2'); end if - if (.not. is_within_bound(stomatal_resistance_option, 1, 3)) then; call sys_abort(1,'model options: stomatal_resistance_option should be 1-3'); end if - if (.not. is_within_bound(evap_srfc_resistance_option, 1, 4)) then; call sys_abort(1,'model options: evap_srfc_resistance_option should be 1-4'); end if - if (.not. is_within_bound(subsurface_option, 1, 3)) then; call sys_abort(1,'model options: subsurface_option should be 1-3'); end if + if (.not. is_within_bound(precip_phase_option, 1, 7)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: precip_phase_option should be 1-7'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(runoff_option, 1, 8)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: runoff_option should be 1-8'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(drainage_option, 1, 8)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: drainage_option should be 1-8'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(frozen_soil_option ,1, 2)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: frozen_soil_option should be 1-2'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(dynamic_vic_option ,1, 3)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: dynamic_vic_option should be 1-3'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(dynamic_veg_option ,1, 9)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: dynamic_veg_option should be 1-9'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(snow_albedo_option ,1, 2)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: snow_albedo_option should be 1-2'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(radiative_transfer_option,1, 3)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: radiative_transfer_option should be 1-3'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(sfc_drag_coeff_option, 1, 2)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: sfc_drag_coeff_option should be 1-3'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(canopy_stom_resist_option, 1, 2)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: canopy_stom_resist_option should be 1-2'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(snowsoil_temp_time_option, 1, 3)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: snowsoil_temp_time_option should be 1-3'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(soil_temp_boundary_option, 1, 2)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: soil_temp_boundary_option should be 1-2'; call log_message(error_flag, error_string); return;end if + if (.not. is_within_bound(supercooled_water_option, 1, 2)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: supercooled_water_option should be 1-2'; call log_message(error_flag, error_string); return;end if + if (.not. is_within_bound(stomatal_resistance_option, 1, 3)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: stomatal_resistance_option should be 1-3'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(evap_srfc_resistance_option, 1, 4)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: evap_srfc_resistance_option should be 1-4'; call log_message(error_flag, error_string); return; end if + if (.not. is_within_bound(subsurface_option, 1, 3)) then; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): model options: subsurface_option should be 1-3'; call log_message(error_flag, error_string); return; end if + ! after reading # of soil layers, allocate local arrays and read soil structure info allocate (zsoil ( 1:nsoil)) ! depth of layer-bottom from soil surface @@ -283,7 +284,7 @@ subroutine ReadNamelist(this, namelist_file) ! read remaining group from namelist read(30, initial_values) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: invalid line in namelist: '//trim(line); call log_message(error_flag, error_string); return; end if close(30) ! calculate total soil depth and populate array for depth of layer-bottom from soil surface @@ -294,64 +295,65 @@ subroutine ReadNamelist(this, namelist_file) zsoil(iz) = -1. * sum(dzsnso(1:iz)) end do else - write(*,'(A)') 'ERROR: required entry dzsnso not found in namelist'; stop + error_flag=NOM_FAILURE; + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry dzsnso not found in namelist'; call log_message(error_flag, error_string); return end if !--------------------------------------------------------------------- ! transfer values to namelist data structure !--------------------------------------------------------------------- - if(dt /= realMissing) then; this%dt = dt; else; write(*,'(A)') 'ERROR: required entry dt not found in namelist'; stop; end if - if(startdate /= stringMissing) then; this%startdate = startdate; else; write(*,'(A)') 'ERROR: required entry startdate not found in namelist'; stop; end if - if(enddate /= stringMissing) then; this%enddate = enddate; else; write(*,'(A)') 'ERROR: required entry enddate not found in namelist'; stop; end if - if(forcing_filename /= stringMissing) then; this%forcing_filename = forcing_filename; else; write(*,'(A)') 'ERROR: required entry forcing_filename not found in namelist'; stop; end if - if(output_filename /= stringMissing) then; this%output_filename = output_filename; else; write(*,'(A)') 'ERROR: required entry output_filename not found in namelist'; stop; end if - if(parameter_dir /= stringMissing) then; this%parameter_dir = parameter_dir; else; write(*,'(A)') 'ERROR: required entry parameter_dir not found in namelist'; stop; end if - if(soil_table /= stringMissing) then; this%soil_table = soil_table; else; write(*,'(A)') 'ERROR: required entry soil_table not found in namelist'; stop; end if - if(general_table /= stringMissing) then; this%general_table = general_table; else; write(*,'(A)') 'ERROR: required entry general_table not found in namelist'; stop; end if - if(noahowp_table /= stringMissing) then; this%noahowp_table = noahowp_table; else; write(*,'(A)') 'ERROR: required entry noahowp_table not found in namelist'; stop; end if - if(soil_class_name /= stringMissing) then; this%soil_class_name = soil_class_name; else; write(*,'(A)') 'ERROR: required entry soil_class_name not found in namelist'; stop; end if - if(veg_class_name /= stringMissing) then; this%veg_class_name = veg_class_name; else; write(*,'(A)') 'ERROR: required entry veg_class_name not found in namelist'; stop; end if + if(dt /= realMissing) then; this%dt = dt; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry dt not found in namelist'; call log_message(error_flag, error_string); return; end if + if(startdate /= stringMissing) then; this%startdate = startdate; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry startdate not found in namelist'; call log_message(error_flag, error_string); return; end if + if(enddate /= stringMissing) then; this%enddate = enddate; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry enddate not found in namelist'; call log_message(error_flag, error_string); return; end if + if(forcing_filename /= stringMissing) then; this%forcing_filename = forcing_filename; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry forcing_filename not found in namelist'; call log_message(error_flag, error_string); return; end if + if(output_filename /= stringMissing) then; this%output_filename = output_filename; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry output_filename not found in namelist'; call log_message(error_flag, error_string); return; end if + if(parameter_dir /= stringMissing) then; this%parameter_dir = parameter_dir; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry parameter_dir not found in namelist'; call log_message(error_flag, error_string); return; end if + if(soil_table /= stringMissing) then; this%soil_table = soil_table; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry soil_table not found in namelist'; call log_message(error_flag, error_string); return; end if + if(general_table /= stringMissing) then; this%general_table = general_table; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry general_table not found in namelist'; call log_message(error_flag, error_string); return; end if + if(noahowp_table /= stringMissing) then; this%noahowp_table = noahowp_table; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry noahowp_table not found in namelist'; call log_message(error_flag, error_string); return; end if + if(soil_class_name /= stringMissing) then; this%soil_class_name = soil_class_name; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry soil_class_name not found in namelist'; call log_message(error_flag, error_string); return; end if + if(veg_class_name /= stringMissing) then; this%veg_class_name = veg_class_name; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry veg_class_name not found in namelist'; call log_message(error_flag, error_string); return; end if - if(lat /= realMissing) then; this%lat = lat; else; write(*,'(A)') 'ERROR: required entry lat not found in namelist'; stop; end if - if(lon /= realMissing) then; this%lon = lon; else; write(*,'(A)') 'ERROR: required entry lon not found in namelist'; stop; end if - if(terrain_slope /= realMissing) then; this%terrain_slope = terrain_slope; else; write(*,'(A)') 'ERROR: required entry terrain_slope not found in namelist'; stop; end if - if(azimuth /= realMissing) then; this%azimuth = azimuth; else; write(*,'(A)') 'ERROR: required entry azimuth not found in namelist'; stop; end if - if(zref /= realMissing) then; this%ZREF = ZREF; else; write(*,'(A)') 'ERROR: required entry ZREF not found in namelist'; stop; end if - if(rain_snow_thresh /= realMissing) then; this%rain_snow_thresh = rain_snow_thresh; else; write(*,'(A)') 'ERROR: required entry rain_snow_thresh not found in namelist'; stop; end if + if(lat /= realMissing) then; this%lat = lat; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry lat not found in namelist'; call log_message(error_flag, error_string); return; end if + if(lon /= realMissing) then; this%lon = lon; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry lon not found in namelist'; call log_message(error_flag, error_string); return; end if + if(terrain_slope /= realMissing) then; this%terrain_slope = terrain_slope; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry terrain_slope not found in namelist'; call log_message(error_flag, error_string); return; end if + if(azimuth /= realMissing) then; this%azimuth = azimuth; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry azimuth not found in namelist'; call log_message(error_flag, error_string); return; end if + if(zref /= realMissing) then; this%ZREF = ZREF; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry ZREF not found in namelist'; call log_message(error_flag, error_string); return; end if + if(rain_snow_thresh /= realMissing) then; this%rain_snow_thresh = rain_snow_thresh; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry rain_snow_thresh not found in namelist'; call log_message(error_flag, error_string); return; end if - if(isltyp /= integerMissing) then; this%isltyp = isltyp; else; write(*,'(A)') 'ERROR: required entry isltyp not found in namelist'; stop; end if - if(nsoil /= integerMissing) then; this%nsoil = nsoil; else; write(*,'(A)') 'ERROR: required entry nsoil not found in namelist'; stop; end if - if(nsnow /= integerMissing) then; this%nsnow = nsnow; else; write(*,'(A)') 'ERROR: required entry nsnow not found in namelist'; stop; end if - if(nveg /= integerMissing) then; this%nveg = nveg; else; write(*,'(A)') 'ERROR: required entry nveg not found in namelist'; stop; end if - if(soil_depth /= integerMissing) then; this%soil_depth = soil_depth; else; write(*,'(A)') 'ERROR: required entry soil_depth not found in namelist'; stop; end if - if(vegtyp /= integerMissing) then; this%vegtyp = vegtyp; else; write(*,'(A)') 'ERROR: required entry vegtyp not found in namelist'; stop; end if - if(croptype /= integerMissing) then; this%croptype = croptype; else; write(*,'(A)') 'ERROR: required entry croptype not found in namelist'; stop; end if - if(sfctyp /= integerMissing) then; this%sfctyp = sfctyp; else; write(*,'(A)') 'ERROR: required entry sfctyp not found in namelist'; stop; end if - if(soilcolor /= integerMissing) then; this%soilcolor = soilcolor; else; write(*,'(A)') 'ERROR: required entry soilcolor not found in namelist'; stop; end if + if(isltyp /= integerMissing) then; this%isltyp = isltyp; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry isltyp not found in namelist'; call log_message(error_flag, error_string); return; end if + if(nsoil /= integerMissing) then; this%nsoil = nsoil; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry nsoil not found in namelist'; call log_message(error_flag, error_string); return; end if + if(nsnow /= integerMissing) then; this%nsnow = nsnow; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry nsnow not found in namelist'; call log_message(error_flag, error_string); return; end if + if(nveg /= integerMissing) then; this%nveg = nveg; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry nveg not found in namelist'; call log_message(error_flag, error_string); return; end if + if(soil_depth /= integerMissing) then; this%soil_depth = soil_depth; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry soil_depth not found in namelist'; call log_message(error_flag, error_string); return; end if + if(vegtyp /= integerMissing) then; this%vegtyp = vegtyp; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry vegtyp not found in namelist'; call log_message(error_flag, error_string); return; end if + if(croptype /= integerMissing) then; this%croptype = croptype; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry croptype not found in namelist'; call log_message(error_flag, error_string); return; end if + if(sfctyp /= integerMissing) then; this%sfctyp = sfctyp; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry sfctyp not found in namelist'; call log_message(error_flag, error_string); return; end if + if(soilcolor /= integerMissing) then; this%soilcolor = soilcolor; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry soilcolor not found in namelist'; call log_message(error_flag, error_string); return; end if - if(zsoil(1) /= realMissing) then; this%zsoil = zsoil; else; write(*,'(A)') 'ERROR: required entry zsoil not found in namelist'; stop; end if - if(dzsnso(1) /= realMissing) then; this%dzsnso = dzsnso; else; write(*,'(A)') 'ERROR: required entry dzsnso not found in namelist'; stop; end if - if(sice(1) /= realMissing) then; this%sice = sice; else; write(*,'(A)') 'ERROR: required entry sice not found in namelist'; stop; end if - if(sh2o(1) /= realMissing) then; this%sh2o = sh2o; else; write(*,'(A)') 'ERROR: required entry sh2o not found in namelist'; stop; end if - if(zwt /= realMissing) then; this%zwt = zwt; else; write(*,'(A)') 'ERROR: required entry zwt not found in namelist'; stop; end if + if(zsoil(1) /= realMissing) then; this%zsoil = zsoil; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry zsoil not found in namelist'; call log_message(error_flag, error_string); return; end if + if(dzsnso(1) /= realMissing) then; this%dzsnso = dzsnso; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry dzsnso not found in namelist'; call log_message(error_flag, error_string); return; end if + if(sice(1) /= realMissing) then; this%sice = sice; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry sice not found in namelist'; call log_message(error_flag, error_string); return; end if + if(sh2o(1) /= realMissing) then; this%sh2o = sh2o; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry sh2o not found in namelist'; call log_message(error_flag, error_string); return; end if + if(zwt /= realMissing) then; this%zwt = zwt; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry zwt not found in namelist'; call log_message(error_flag, error_string); return; end if - if(precip_phase_option /= integerMissing) then; this%precip_phase_option = precip_phase_option; else; write(*,'(A)') 'ERROR: required entry precip_phase_option not found in namelist'; stop; end if - if(runoff_option /= integerMissing) then; this%runoff_option = runoff_option; else; write(*,'(A)') 'ERROR: required entry runoff_option not found in namelist'; stop; end if - if(drainage_option /= integerMissing) then; this%drainage_option = drainage_option; else; write(*,'(A)') 'ERROR: required entry drainage_option not found in namelist'; stop; end if - if(frozen_soil_option /= integerMissing) then; this%frozen_soil_option = frozen_soil_option; else; write(*,'(A)') 'ERROR: required entry frozen_soil_option not found in namelist'; stop; end if - if(dynamic_vic_option /= integerMissing) then; this%dynamic_vic_option = dynamic_vic_option; else; write(*,'(A)') 'ERROR: required entry dynamic_vic_option not found in namelist'; stop; end if - if(dynamic_veg_option /= integerMissing) then; this%dynamic_veg_option = dynamic_veg_option; else; write(*,'(A)') 'ERROR: required entry dynamic_veg_option not found in namelist'; stop; end if - if(snow_albedo_option /= integerMissing) then; this%snow_albedo_option = snow_albedo_option; else; write(*,'(A)') 'ERROR: required entry snow_albedo_option not found in namelist'; stop; end if - if(radiative_transfer_option /= integerMissing) then; this%radiative_transfer_option = radiative_transfer_option; else; write(*,'(A)') 'ERROR: required entry radiative_transfer_option not found in namelist'; stop; end if - if(sfc_drag_coeff_option /= integerMissing) then; this%sfc_drag_coeff_option = sfc_drag_coeff_option; else; write(*,'(A)') 'ERROR: required entry sfc_drag_coeff_option not found in namelist'; stop; end if - if(crop_model_option /= integerMissing) then; this%crop_model_option = crop_model_option; else; write(*,'(A)') 'ERROR: required entry crop_model_option not found in namelist'; stop; end if - if(canopy_stom_resist_option /= integerMissing) then; this%canopy_stom_resist_option = canopy_stom_resist_option; else; write(*,'(A)') 'ERROR: required entry canopy_stom_resist_option not found in namelist'; stop; end if - if(snowsoil_temp_time_option /= integerMissing) then; this%snowsoil_temp_time_option = snowsoil_temp_time_option; else; write(*,'(A)') 'ERROR: required entry snowsoil_temp_time_option not found in namelist'; stop; end if - if(soil_temp_boundary_option /= integerMissing) then; this%soil_temp_boundary_option = soil_temp_boundary_option; else; write(*,'(A)') 'ERROR: required entry soil_temp_boundary_option not found in namelist'; stop; end if - if(supercooled_water_option /= integerMissing) then; this%supercooled_water_option = supercooled_water_option; else; write(*,'(A)') 'ERROR: required entry supercooled_water_option not found in namelist'; stop; end if - if(stomatal_resistance_option /= integerMissing) then; this%stomatal_resistance_option = stomatal_resistance_option; else; write(*,'(A)') 'ERROR: required entry stomatal_resistance_option not found in namelist'; stop; end if - if(evap_srfc_resistance_option /= integerMissing) then; this%evap_srfc_resistance_option = evap_srfc_resistance_option; else; write(*,'(A)') 'ERROR: required entry evap_srfc_resistance_option not found in namelist'; stop; end if - if(subsurface_option /= integerMissing) then; this%subsurface_option = subsurface_option; else; write(*,'(A)') 'ERROR: required entry subsurface_option not found in namelist'; stop; end if + if(precip_phase_option /= integerMissing) then; this%precip_phase_option = precip_phase_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry precip_phase_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(runoff_option /= integerMissing) then; this%runoff_option = runoff_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry runoff_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(drainage_option /= integerMissing) then; this%drainage_option = drainage_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry drainage_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(frozen_soil_option /= integerMissing) then; this%frozen_soil_option = frozen_soil_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry frozen_soil_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(dynamic_vic_option /= integerMissing) then; this%dynamic_vic_option = dynamic_vic_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry dynamic_vic_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(dynamic_veg_option /= integerMissing) then; this%dynamic_veg_option = dynamic_veg_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry dynamic_veg_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(snow_albedo_option /= integerMissing) then; this%snow_albedo_option = snow_albedo_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry snow_albedo_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(radiative_transfer_option /= integerMissing) then; this%radiative_transfer_option = radiative_transfer_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry radiative_transfer_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(sfc_drag_coeff_option /= integerMissing) then; this%sfc_drag_coeff_option = sfc_drag_coeff_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry sfc_drag_coeff_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(crop_model_option /= integerMissing) then; this%crop_model_option = crop_model_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry crop_model_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(canopy_stom_resist_option /= integerMissing) then; this%canopy_stom_resist_option = canopy_stom_resist_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry canopy_stom_resist_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(snowsoil_temp_time_option /= integerMissing) then; this%snowsoil_temp_time_option = snowsoil_temp_time_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry snowsoil_temp_time_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(soil_temp_boundary_option /= integerMissing) then; this%soil_temp_boundary_option = soil_temp_boundary_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry soil_temp_boundary_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(supercooled_water_option /= integerMissing) then; this%supercooled_water_option = supercooled_water_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry supercooled_water_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(stomatal_resistance_option /= integerMissing) then; this%stomatal_resistance_option = stomatal_resistance_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry stomatal_resistance_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(evap_srfc_resistance_option /= integerMissing) then; this%evap_srfc_resistance_option = evap_srfc_resistance_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry evap_srfc_resistance_option not found in namelist'; call log_message(error_flag, error_string); return; end if + if(subsurface_option /= integerMissing) then; this%subsurface_option = subsurface_option; else; error_flag=NOM_FAILURE; write(error_string,'(A)') moduleName//' - '//subroutineName//'(): ERROR: required entry subsurface_option not found in namelist'; call log_message(error_flag, error_string); return; end if ! store missing values as well this%integerMissing = integerMissing diff --git a/src/ParametersRead.f90 b/src/ParametersRead.f90 index 0f04f0c6..fb6c3607 100644 --- a/src/ParametersRead.f90 +++ b/src/ParametersRead.f90 @@ -1,5 +1,7 @@ MODULE ParametersRead +use ErrorCheckModule + ! Parameter table read routines: ! Adapted from the original module_sf_noahmplsm.F module with several modifications ! 1. made _TABLE variables public. @@ -7,6 +9,8 @@ MODULE ParametersRead ! 3. replace error handle routine ("wrf_error_fatal") with "handle_err" implicit none + character(len=*), PARAMETER :: moduleName='ParametersRead' + private :: moduleName save @@ -314,6 +318,7 @@ SUBROUTINE read_veg_parameters(param_dir, noahowp_table, DATASET_IDENTIFIER) character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table character(len=*), intent(in) :: DATASET_IDENTIFIER + character(len=*), PARAMETER :: subroutineName = 'read_veg_parameters' integer :: ierr integer :: IK,IM logical :: file_named @@ -451,7 +456,10 @@ SUBROUTINE read_veg_parameters(param_dir, noahowp_table, DATASET_IDENTIFIER) end if if (ierr /= 0) then - call handle_err(ierr, "ParametersRead.f90: read_veg_parameters: Cannot find file MPTABLE.TBL") + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif if ( trim(DATASET_IDENTIFIER) == "USGS" ) then @@ -461,8 +469,11 @@ SUBROUTINE read_veg_parameters(param_dir, noahowp_table, DATASET_IDENTIFIER) read(15,modis_veg_categories) read(15,modis_veg_parameters) else - write(*,'("WARNING: DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) - call handle_err(ierr, 'ParametersRead.f90: read_veg_parameters: Unrecognized DATASET_IDENTIFIER in subroutine read_VEG_PARAMETERS') + error_flag = NOM_FAILURE + write(error_string,'(A,A)') moduleName//' - '//subroutineName//'(): Unrecognized DATASET_IDENTIFIER: ', trim(DATASET_IDENTIFIER) + call log_message(error_flag, error_string) + close(15) + return endif close(15) @@ -569,17 +580,18 @@ SUBROUTINE read_veg_parameters(param_dir, noahowp_table, DATASET_IDENTIFIER) END SUBROUTINE read_veg_parameters - SUBROUTINE read_soil_parameters(param_dir, soil_table, general_table, soil_class_name) + SUBROUTINE read_soil_parameters(param_dir, soil_table, general_table, & + soil_class_name) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: soil_table character(len=*), intent(in) :: general_table character(len=*), intent(in) :: soil_class_name + character(len=*), PARAMETER :: subroutineName = 'read_soil_parameters' integer :: IERR character(len=20) :: SLTYPE integer :: ITMP, NUM_SLOPE, LC integer :: iLine ! loop index - character(len=256) :: message logical :: file_named @@ -619,10 +631,13 @@ SUBROUTINE read_soil_parameters(param_dir, soil_table, general_table, soil_class open(21, form='formatted',status='old',iostat=ierr) end if - if (ierr/=0) then - write(message,fmt='(A)') 'ParametersRead.f90: read_soil_parameters: failure opening SOILPARM.TBL' - call handle_err(ierr, message) - end if + if (ierr /= 0) then + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): failure opening SOILPARM.TBL' + call log_message(error_flag, error_string) + return + endif + do iLine = 1,100 READ (21,*) SLTYPE @@ -655,8 +670,11 @@ SUBROUTINE read_soil_parameters(param_dir, soil_table, general_table, soil_class end if if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_soil_parameters: failure opening GENPARM.TBL') - end if + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): failure opening GENPARM.TBL' + call log_message(error_flag, error_string) + return + endif read (22,*) read (22,*) @@ -702,6 +720,7 @@ SUBROUTINE read_rad_parameters(param_dir, noahowp_table) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table + character(len=*), PARAMETER :: subroutineName = 'read_rad_parameters' integer :: ierr logical :: file_named @@ -731,7 +750,10 @@ SUBROUTINE read_rad_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_rad_parameters: Cannot find file MPTABLE.TBL') + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif read(15,rad_parameters) @@ -754,6 +776,7 @@ subroutine read_global_parameters(param_dir, noahowp_table) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table + character(len=*), PARAMETER :: subroutineName = 'read_global_parameters' integer :: ierr logical :: file_named @@ -800,7 +823,10 @@ subroutine read_global_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_global_parameters: Cannot find file MPTABLE.TBL') + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif read(15,global_parameters) @@ -835,6 +861,7 @@ SUBROUTINE read_crop_parameters(param_dir, noahowp_table) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table + character(len=*), PARAMETER :: subroutineName = 'read_crop_parameters' integer :: ierr logical :: file_named @@ -979,8 +1006,11 @@ SUBROUTINE read_crop_parameters(param_dir, noahowp_table) open(15, status='old', form='formatted', action='read', iostat=ierr) end if - if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_crop_parameters: Cannot find file MPTABLE.TBL') + if (ierr /= 0) then + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif read(15,crop_parameters) @@ -1130,6 +1160,7 @@ SUBROUTINE read_irrigation_parameters(param_dir, noahowp_table) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table + character(len=*), PARAMETER :: subroutineName = 'read_irrigation_parameters' integer :: ierr logical :: file_named @@ -1163,8 +1194,11 @@ SUBROUTINE read_irrigation_parameters(param_dir, noahowp_table) open(15, status='old', form='formatted', action='read', iostat=ierr) end if - if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_irrigation_parameters: Cannot find file MPTABLE.TBL') + if (ierr /= 0) then + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif read(15,irrigation_parameters) @@ -1186,7 +1220,9 @@ SUBROUTINE read_tiledrain_parameters(param_dir, noahowp_table) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table + character(len=*), PARAMETER :: subroutineName = 'read_tiledrain_parameters' integer :: ierr + logical :: file_named real, dimension(MAX_SOILTYP) :: TDSMC_FAC integer, dimension(MAX_SOILTYP) :: TD_DEPTH @@ -1222,9 +1258,13 @@ SUBROUTINE read_tiledrain_parameters(param_dir, noahowp_table) else open(15, status='old', form='formatted', action='read', iostat=ierr) end if - if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_tiledrain_parameters: Cannot find file MPTABLE.TBL') + if (ierr /= 0) then + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif + read(15,tiledrain_parameters) close(15) TDSMCFAC_TABLE = TDSMC_FAC @@ -1247,6 +1287,7 @@ SUBROUTINE read_optional_parameters(param_dir, noahowp_table) implicit none character(len=*), intent(in) :: param_dir character(len=*), intent(in) :: noahowp_table + character(len=*), PARAMETER :: subroutineName = 'read_optional_parameters' integer :: ierr logical :: file_named @@ -1277,7 +1318,10 @@ SUBROUTINE read_optional_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then - call handle_err(ierr, 'ParametersRead.f90: read_optional_parameters: Cannot find file MPTABLE.TBL') + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): Cannot find file MPTABLE.TBL' + call log_message(error_flag, error_string) + return endif read(15,optional_parameters) @@ -1285,16 +1329,4 @@ SUBROUTINE read_optional_parameters(param_dir, noahowp_table) END SUBROUTINE read_optional_parameters - - SUBROUTINE handle_err(err,message) - implicit none - integer, intent(in) :: err ! error code - character(*),intent(in) :: message ! error message - if(err/=0)then - write(*,*) 'FATAL ERROR: '//trim(message) - call flush(6) - stop - endif - END SUBROUTINE handle_err - END MODULE ParametersRead diff --git a/src/ParametersType.f90 b/src/ParametersType.f90 index f57a2ff0..57b498ae 100644 --- a/src/ParametersType.f90 +++ b/src/ParametersType.f90 @@ -2,6 +2,7 @@ module ParametersType use NamelistRead, only: namelist_type use ParametersRead +use ErrorCheckModule implicit none save @@ -206,12 +207,26 @@ subroutine paramRead(this, namelist) !dataset_identifier = "MODIFIED_IGBP_MODIS_NOAH" ! This can be in namelist !call read_veg_parameters(namelist%parameter_dir, namelist%noahowp_table, dataset_identifier) + call read_soil_parameters(namelist%parameter_dir, namelist%soil_table, namelist%general_table, namelist%soil_class_name) + if (error_flag == NOM_FAILURE) then + return + end if + call read_veg_parameters(namelist%parameter_dir, namelist%noahowp_table, namelist%veg_class_name) - !call read_soil_parameters(namelist%parameter_dir, namelist%soil_table, namelist%general_table) + if (error_flag == NOM_FAILURE) then + return + end if call read_rad_parameters(namelist%parameter_dir, namelist%noahowp_table) + if (error_flag == NOM_FAILURE) then + return + end if + call read_global_parameters(namelist%parameter_dir, namelist%noahowp_table) + if (error_flag == NOM_FAILURE) then + return + end if !--------------------------------------------------------------------- ! transfer to structure diff --git a/src/RunModule.f90 b/src/RunModule.f90 index cb357b84..d8479319 100644 --- a/src/RunModule.f90 +++ b/src/RunModule.f90 @@ -10,6 +10,7 @@ module RunModule use WaterType use ForcingType use EnergyType + use ErrorType use AsciiReadModule use OutputModule use UtilitiesModule @@ -18,8 +19,10 @@ module RunModule use EnergyModule use WaterModule use DateTimeUtilsModule + use ErrorCheckModule implicit none + type :: noahowp_type type(namelist_type) :: namelist type(levels_type) :: levels @@ -29,6 +32,7 @@ module RunModule type(water_type) :: water type(forcing_type) :: forcing type(energy_type) :: energy + type(error_type) :: error end type noahowp_type contains @@ -48,24 +52,39 @@ SUBROUTINE initialize_from_file (model, config_filename) parameters => model%parameters, & water => model%water, & forcing => model%forcing, & - energy => model%energy) + energy => model%energy, & + error => model%error) !--------------------------------------------------------------------- ! initialize !--------------------------------------------------------------------- + call error%Init() + call namelist%ReadNamelist(config_filename) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if call levels%Init call levels%InitTransfer(namelist) call domain%Init(namelist) call domain%InitTransfer(namelist) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if call options%Init() call options%InitTransfer(namelist) call parameters%Init(namelist) call parameters%paramRead(namelist) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if call forcing%Init(namelist) call forcing%InitTransfer(namelist) @@ -196,6 +215,10 @@ SUBROUTINE initialize_from_file (model, config_filename) !--------------------------------------------------------------------- ! --- AWW: calculate start and end utimes & records for requested station data read period --- call get_utime_list (domain%start_datetime, domain%end_datetime, domain%dt, domain%sim_datetimes) ! makes unix-time list for desired records (end-of-timestep) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if domain%ntime = size (domain%sim_datetimes) !print *, "---------"; !print *, 'Simulation startdate = ', domain%startdate, ' enddate = ', domain%enddate, ' dt(sec) = ', domain%dt, ' ntimes = ', domain%ntime ! YYYYMMDD dates @@ -209,6 +232,10 @@ SUBROUTINE initialize_from_file (model, config_filename) !--------------------------------------------------------------------- #ifndef NGEN_FORCING_ACTIVE call open_forcing_file(namelist%forcing_filename) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if #endif !--------------------------------------------------------------------- @@ -246,6 +273,10 @@ SUBROUTINE advance_in_time(model) type (noahowp_type), intent (inout) :: model call solve_noahowp(model) + if (error_flag == NOM_FAILURE) then + call save_error_state(model%error%error_flag, model%error%error_string) + return + end if model%domain%itime = model%domain%itime + 1 ! increment the integer time by 1 model%domain%time_dbl = dble(model%domain%time_dbl + model%domain%dt) ! increment model time in seconds by DT @@ -267,7 +298,8 @@ SUBROUTINE solve_noahowp(model) parameters => model%parameters, & water => model%water, & forcing => model%forcing, & - energy => model%energy) + energy => model%energy, & + error => model%error) ! Compute the current UNIX datetime domain%curr_datetime = domain%sim_datetimes(domain%itime) ! use end-of-timestep datetimes because initial var values are being written @@ -284,12 +316,20 @@ SUBROUTINE solve_noahowp(model) #ifndef NGEN_FORCING_ACTIVE call read_forcing_text(iunit, domain%nowdate, forcing_timestep, & forcing%UU, forcing%VV, forcing%SFCTMP, forcing%Q2, forcing%SFCPRS, forcing%SOLDN, forcing%LWDN, forcing%PRCP, ierr) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if #endif !--------------------------------------------------------------------- ! call the main utility routines !--------------------------------------------------------------------- call UtilitiesMain (domain%itime, domain, forcing, energy) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if !--------------------------------------------------------------------- ! call the main forcing routines @@ -308,6 +348,10 @@ SUBROUTINE solve_noahowp(model) !--------------------------------------------------------------------- call EnergyMain (domain, levels, options, parameters, forcing, energy, water) + if (error_flag == NOM_FAILURE) then + call save_error_state(error%error_flag, error%error_string) + return + end if !--------------------------------------------------------------------- ! call the main water routines (canopy + snow + soil water components) diff --git a/src/UtilitiesModule.f90 b/src/UtilitiesModule.f90 index 6af6cb15..34c6cde4 100644 --- a/src/UtilitiesModule.f90 +++ b/src/UtilitiesModule.f90 @@ -9,8 +9,11 @@ module UtilitiesModule use DomainType use EnergyType + use ErrorCheckModule use ForcingType implicit none + character(len=*), PARAMETER :: moduleName='UtilitiesModule' + private :: moduleName contains @@ -28,19 +31,26 @@ SUBROUTINE UtilitiesMain (itime, domain, forcing, energy) idt = itime * (domain%dt / 60) ! calculate current 'nowdate' from start date + integer length of run to current time - call geth_newdate(domain%startdate, idt, & ! in - domain%nowdate) ! out + call geth_newdate(domain%startdate, idt, & ! in + domain%nowdate) ! out + if (error_flag == NOM_FAILURE) then + return + end if ! calculate current declination of direct solar radiation input call calc_declin(domain%nowdate(1:4)//"-"//domain%nowdate(5:6)//"-"//domain%nowdate(7:8)//"_"//domain%nowdate(9:10)//":"//domain%nowdate(11:12)//":00", & ! in domain%lat, domain%lon, domain%terrain_slope, domain%azimuth,& ! in energy%cosz, energy%cosz_horiz,forcing%yearlen, forcing%julian) ! out + if (error_flag == NOM_FAILURE) then + return + end if + END SUBROUTINE UtilitiesMain ! calculate current 'nowdate' from start date + integer length of run to current time - subroutine geth_newdate (odate, idt, & ! in - ndate) ! out + subroutine geth_newdate (odate, idt, & ! in + ndate) ! out IMPLICIT NONE @@ -75,7 +85,8 @@ subroutine geth_newdate (odate, idt, & ! in integer :: ifrc logical :: opass ! logical for whether odate components pass their checks character (len=10) :: hfrc - character (len=1) :: sp + character (len=1) :: sp + character (len=*), PARAMETER :: subroutineName = 'geth_newdate' logical :: punctuated ! logical for whether the date string has hyphens to separate logical :: idtdy ! logical for whether idt has units of days @@ -209,8 +220,10 @@ subroutine geth_newdate (odate, idt, & ! in ! If opass = false, then cancel the run if (.not.opass) then - write(*,*) 'Crazy ODATE: ', odate(1:olen), olen - call abort() + error_flag = NOM_FAILURE + write(error_string,'(A,A)') moduleName//' - '//subroutineName//'(): Crazy ODATE: ',odate(1:olen) + call log_message(error_flag, trim(error_string)) + return end if ! Date Checks are completed. Continue. @@ -258,10 +271,10 @@ subroutine geth_newdate (odate, idt, & ! in nsec = 0 nfrac = 0 else - write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & - olen - write(*,*) odate(1:olen) - call abort() + error_flag = NOM_FAILURE + write(error_string,'(A,I3)') moduleName//' - '//subroutineName//'(): Strange length for ODATE: ',olen + call log_message(error_flag, trim(error_string)) + return end if if (idt >= 0) then @@ -407,7 +420,10 @@ subroutine geth_newdate (odate, idt, & ! in 8 format(i4,i2.2,i2.2) else - stop "DATELEN PROBLEM" + error_flag = NOM_FAILURE + write(error_string,'(A)') moduleName//' - '//subroutineName//'(): DATELEN PROBLEM' + call log_message(error_flag, trim(error_string)) + return end if endif @@ -427,6 +443,7 @@ subroutine geth_idts (newdate, olddate, idt) character(len=24) :: ndate character(len=24) :: odate character (len=24) :: tdate + character (len=*), PARAMETER :: subroutineName = 'geth_idts' integer :: olen ! length of olddate integer :: nlen ! length of newdate integer :: yrnew ! year associated with "ndate" @@ -456,8 +473,10 @@ subroutine geth_idts (newdate, olddate, idt) olen = len(olddate) nlen = len(newdate) if (nlen /= olen) then - write(*,'("GETH_IDTS: NLEN /= OLEN: ", A, 3x, A)') newdate(1:nlen), olddate(1:olen) - call abort + error_flag = NOM_FAILURE + write(error_string,'(A,A,2x,A)') moduleName//' - '//subroutineName//'(): NLEN /= OLEN: ',newdate(1:nlen), olddate(1:olen) + call log_message(error_flag, trim(error_string)) + return endif if (olddate > newdate) then @@ -673,13 +692,17 @@ subroutine geth_idts (newdate, olddate, idt) end if if (.not. npass) then - print*, 'Screwy NDATE: ', ndate(1:nlen) - call abort() + error_flag = NOM_FAILURE + write(error_string,'(A,A)') moduleName//' - '//subroutineName//'(): Screwy NDATE: ',ndate(1:nlen) + call log_message(error_flag, trim(error_string)) + return end if if (.not. opass) then - print*, 'Screwy ODATE: ', odate(1:olen) - call abort() + error_flag = NOM_FAILURE + write(error_string,'(A,A)') moduleName//' - '//subroutineName//'(): Screwy ODATE: ',odate(1:olen) + call log_message(error_flag, trim(error_string)) + return end if ! Date Checks are completed. Continue. @@ -807,7 +830,7 @@ end function nmdays SUBROUTINE calc_declin (nowdate, & ! in latitude, longitude, slope, azimuth, & ! in - cosz, cosz_horiz, yearlen, julian) ! out + cosz, cosz_horiz, yearlen, julian) ! out !--------------------------------------------------------------------- IMPLICIT NONE !--------------------------------------------------------------------- @@ -867,6 +890,9 @@ SUBROUTINE calc_declin (nowdate, & ! in ! Determine the Julian time (floating-point day of year) call geth_idts(nowdate(1:10), nowdate(1:4)//"-01-01", iday) + if (error_flag == NOM_FAILURE) then + return + endif read(nowdate(12:13), *) ihour read(nowdate(15:16), *) iminute read(nowdate(18:19), *) isecond @@ -922,4 +948,4 @@ SUBROUTINE calc_declin (nowdate, & ! in END SUBROUTINE calc_declin -end module UtilitiesModule \ No newline at end of file +end module UtilitiesModule diff --git a/test/Makefile b/test/Makefile index 6afddc54..9a9b4ef7 100644 --- a/test/Makefile +++ b/test/Makefile @@ -7,6 +7,7 @@ include ../user_build_options OBJS = \ ../src/ErrorCheckModule.o \ + ../src/ErrorType.o \ ../src/NamelistRead.o \ ../src/ParametersRead.o \ ../src/LevelsType.o \