diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index 0145033aaab..2cd360883bd 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -1,24 +1,24 @@ module SimulationCreateModule - use KindModule, only: DP, I4B, write_kindinfo - use ConstantsModule, only: LINELENGTH, LENMODELNAME, LENBIGLINE, DZERO - use SimVariablesModule, only: simfile, simlstfile, iout + use KindModule, only: DP, I4B, write_kindinfo + use ConstantsModule, only: LINELENGTH, LENMODELNAME, LENBIGLINE, DZERO + use SimVariablesModule, only: simfile, simlstfile, iout use GenericUtilitiesModule, only: sim_message, write_centered - use SimModule, only: store_error, count_errors, & - store_error_unit, MaxErrors - use VersionModule, only: write_listfile_header - use InputOutputModule, only: getunit, urword, openfile - use ArrayHandlersModule, only: expandarray, ifind - use BaseModelModule, only: BaseModelType - use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & - GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, AddSolutionGroupToList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use ListsModule, only: basesolutionlist, basemodellist, & - solutiongrouplist, baseexchangelist - use BaseModelModule, only: GetBaseModelFromList - use BlockParserModule, only: BlockParserType - use ListModule, only: ListType + use SimModule, only: store_error, count_errors, & + store_error_unit, MaxErrors + use VersionModule, only: write_listfile_header + use InputOutputModule, only: getunit, urword, openfile + use ArrayHandlersModule, only: expandarray, ifind + use BaseModelModule, only: BaseModelType + use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & + GetBaseSolutionFromList + use SolutionGroupModule, only: SolutionGroupType, AddSolutionGroupToList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use ListsModule, only: basesolutionlist, basemodellist, & + solutiongrouplist, baseexchangelist + use BaseModelModule, only: GetBaseModelFromList + use BlockParserModule, only: BlockParserType + use ListModule, only: ListType implicit none private @@ -29,7 +29,7 @@ module SimulationCreateModule character(len=LENMODELNAME), allocatable, dimension(:) :: modelname type(BlockParserType) :: parser - contains +contains !> @brief Read the simulation name file and initialize the models, exchanges !< @@ -39,7 +39,7 @@ subroutine simulation_cr() character(len=LINELENGTH) :: line ! ------------------------------------------------------------------------------ ! - ! -- initialize iout + ! -- initialize iout iout = 0 ! ! -- Open simulation list file @@ -47,8 +47,8 @@ subroutine simulation_cr() call openfile(iout, 0, simlstfile, 'LIST', filstat_opt='REPLACE') ! ! -- write simlstfile to stdout - write(line,'(2(1x,A))') 'Writing simulation list file:', & - trim(adjustl(simlstfile)) + write (line, '(2(1x,A))') 'Writing simulation list file:', & + trim(adjustl(simlstfile)) call sim_message(line) call write_listfile_header(iout) ! @@ -58,7 +58,7 @@ subroutine simulation_cr() ! -- Return return end subroutine simulation_cr - + !> @brief Deallocate simulation variables !< subroutine simulation_da() @@ -67,7 +67,7 @@ subroutine simulation_da() ! ------------------------------------------------------------------------------ ! ! -- variables - deallocate(modelname) + deallocate (modelname) ! ! -- Return return @@ -82,7 +82,7 @@ end subroutine simulation_da !< subroutine read_simulation_namefile(namfile) ! -- dummy - character(len=*),intent(in) :: namfile !< simulation name file + character(len=*), intent(in) :: namfile !< simulation name file ! -- local character(len=LINELENGTH) :: line ! ------------------------------------------------------------------------------ @@ -92,7 +92,7 @@ subroutine read_simulation_namefile(namfile) call openfile(inunit, iout, namfile, 'NAM') ! ! -- write name of namfile to stdout - write(line,'(2(1x,a))') 'Using Simulation name file:', namfile + write (line, '(2(1x,a))') 'Using Simulation name file:', namfile call sim_message(line, skipafter=1) ! ! -- Initialize block parser @@ -121,7 +121,7 @@ subroutine read_simulation_namefile(namfile) call parser%Clear() ! ! -- Go through each solution and assign exchanges accordingly - call assign_exchanges() + call assign_exchanges() ! ! -- Return return @@ -143,44 +143,44 @@ subroutine options_create() ! ! -- Process OPTIONS block call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION OPTIONS' + write (iout, '(/1x,a)') 'READING SIMULATION OPTIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('CONTINUE') - isimcontinue = 1 - write(iout, '(4x, a)') & - 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' - case ('NOCHECK') - isimcheck = 0 - write(iout, '(4x, a)') & - 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' - case ('MEMORY_PRINT_OPTION') - errmsg = '' - call parser%GetStringCaps(keyword) - call mem_set_print_option(iout, keyword, errmsg) - if (errmsg /= ' ') then - call store_error(errmsg) - call parser%StoreErrorUnit() - endif - case ('MAXERRORS') - imax = parser%GetInteger() - call MaxErrors(imax) - write(iout, '(4x, a, i0)') & - 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', imax - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION OPTION: ', & - trim(keyword) + case ('CONTINUE') + isimcontinue = 1 + write (iout, '(4x, a)') & + 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' + case ('NOCHECK') + isimcheck = 0 + write (iout, '(4x, a)') & + 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' + case ('MEMORY_PRINT_OPTION') + errmsg = '' + call parser%GetStringCaps(keyword) + call mem_set_print_option(iout, keyword, errmsg) + if (errmsg /= ' ') then call store_error(errmsg) call parser%StoreErrorUnit() + end if + case ('MAXERRORS') + imax = parser%GetInteger() + call MaxErrors(imax) + write (iout, '(4x, a, i0)') & + 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', imax + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION OPTION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION OPTIONS' + write (iout, '(1x,a)') 'END OF SIMULATION OPTIONS' end if ! ! -- return @@ -206,27 +206,27 @@ subroutine timing_create() ! ! -- Process TIMING block call parser%GetBlock('TIMING', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION TIMING' + write (iout, '(/1x,a)') 'READING SIMULATION TIMING' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('TDIS6') - found_tdis = .true. - call parser%GetString(line) - call tdis_cr(line) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION TIMING: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('TDIS6') + found_tdis = .true. + call parser%GetString(line) + call tdis_cr(line) + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION TIMING: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION TIMING' + write (iout, '(1x,a)') 'END OF SIMULATION TIMING' else call store_error('****ERROR. Did not find TIMING block in simulation'// & ' control file.') @@ -234,10 +234,10 @@ subroutine timing_create() end if ! ! -- Ensure that TDIS was found - if(.not. found_tdis) then + if (.not. found_tdis) then call store_error('****ERROR. TDIS not found in TIMING block.') call parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -247,9 +247,9 @@ end subroutine timing_create !< subroutine models_create() ! -- modules - use GwfModule, only: gwf_cr - use GwtModule, only: gwt_cr - use ConstantsModule, only: LENMODELNAME + use GwfModule, only: gwf_cr + use GwtModule, only: gwt_cr + use ConstantsModule, only: LENMODELNAME ! -- dummy ! -- local integer(I4B) :: ierr @@ -262,32 +262,32 @@ subroutine models_create() ! ! -- Process MODELS block call parser%GetBlock('MODELS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION MODELS' + write (iout, '(/1x,a)') 'READING SIMULATION MODELS' im = 0 do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('GWF6') - call parser%GetString(fname) - call add_model(im, 'GWF6', mname) - call gwf_cr(fname, im, modelname(im)) - case ('GWT6') - call parser%GetString(fname) - call add_model(im, 'GWT6', mname) - call gwt_cr(fname, im, modelname(im)) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION MODEL: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('GWF6') + call parser%GetString(fname) + call add_model(im, 'GWF6', mname) + call gwf_cr(fname, im, modelname(im)) + case ('GWT6') + call parser%GetString(fname) + call add_model(im, 'GWT6', mname) + call gwt_cr(fname, im, modelname(im)) + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION MODEL: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION MODELS' + write (iout, '(1x,a)') 'END OF SIMULATION MODELS' else call store_error('****ERROR. Did not find MODELS block in simulation'// & ' control file.') @@ -302,9 +302,9 @@ end subroutine models_create !< subroutine exchanges_create() ! -- modules - use GwfGwfExchangeModule, only: gwfexchange_create - use GwfGwtExchangeModule, only: gwfgwt_cr - use GwtGwtExchangeModule, only: gwtexchange_create + use GwfGwfExchangeModule, only: gwfexchange_create + use GwfGwtExchangeModule, only: gwfgwt_cr + use GwtGwtExchangeModule, only: gwtexchange_create ! -- dummy ! -- local integer(I4B) :: ierr @@ -320,9 +320,9 @@ subroutine exchanges_create() &'file. Could not find model: ', a)" ! ------------------------------------------------------------------------------ call parser%GetBlock('EXCHANGES', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION EXCHANGES' + write (iout, '(/1x,a)') 'READING SIMULATION EXCHANGES' id = 0 do call parser%GetNextLine(endOfBlock) @@ -337,39 +337,39 @@ subroutine exchanges_create() ! find model index in list m1 = ifind(modelname, name1) - if(m1 < 0) then - write(errmsg, fmtmerr) trim(name1) + if (m1 < 0) then + write (errmsg, fmtmerr) trim(name1) call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if m2 = ifind(modelname, name2) - if(m2 < 0) then - write(errmsg, fmtmerr) trim(name2) + if (m2 < 0) then + write (errmsg, fmtmerr) trim(name2) call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if - write(iout, '(4x,a,a,i0,a,i0,a,i0)') trim(keyword), ' exchange ', & - id, ' will be created to connect model ', m1, ' with model ', m2 + write (iout, '(4x,a,a,i0,a,i0,a,i0)') trim(keyword), ' exchange ', & + id, ' will be created to connect model ', m1, ' with model ', m2 select case (keyword) - case ('GWF6-GWF6') - call gwfexchange_create(fname, id, m1, m2) - case ('GWF6-GWT6') - call gwfgwt_cr(fname, id, m1, m2) - case ('GWT6-GWT6') - call gwtexchange_create(fname, id, m1, m2) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('GWF6-GWF6') + call gwfexchange_create(fname, id, m1, m2) + case ('GWF6-GWT6') + call gwfgwt_cr(fname, id, m1, m2) + case ('GWT6-GWT6') + call gwtexchange_create(fname, id, m1, m2) + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION EXCHANGES' + write (iout, '(1x,a)') 'END OF SIMULATION EXCHANGES' else - call store_error('****ERROR. Did not find EXCHANGES block in '// & + call store_error('****ERROR. Did not find EXCHANGES block in '// & 'simulation control file.') call parser%StoreErrorUnit() end if @@ -382,17 +382,17 @@ end subroutine exchanges_create !< subroutine solution_groups_create() ! -- modules - use SolutionGroupModule, only: SolutionGroupType, & - solutiongroup_create - use BaseSolutionModule, only: BaseSolutionType - use BaseModelModule, only: BaseModelType - use BaseExchangeModule, only: BaseExchangeType - use NumericalSolutionModule, only: solution_create + use SolutionGroupModule, only: SolutionGroupType, & + solutiongroup_create + use BaseSolutionModule, only: BaseSolutionType + use BaseModelModule, only: BaseModelType + use BaseExchangeModule, only: BaseExchangeType + use NumericalSolutionModule, only: solution_create ! -- dummy ! -- local - type(SolutionGroupType), pointer :: sgp - class(BaseSolutionType), pointer :: sp - class(BaseModelType), pointer :: mp + type(SolutionGroupType), pointer :: sgp + class(BaseSolutionType), pointer :: sp + class(BaseModelType), pointer :: mp integer(I4B) :: ierr logical :: isfound, endOfBlock integer(I4B) :: isoln @@ -405,9 +405,9 @@ subroutine solution_groups_create() character(len=LINELENGTH) :: fname, mname ! -- formats character(len=*), parameter :: fmterrmxiter = & - "('ERROR. MXITER IS SET TO ', i0, ' BUT THERE IS ONLY ONE SOLUTION', & - &' IN SOLUTION GROUP ', i0, '. SET MXITER TO 1 IN SIMULATION CONTROL', & - &' FILE.')" + "('ERROR. MXITER IS SET TO ', i0, ' BUT THERE IS ONLY ONE SOLUTION', & + &' IN SOLUTION GROUP ', i0, '. SET MXITER TO 1 IN SIMULATION CONTROL', & + &' FILE.')" ! ------------------------------------------------------------------------------ ! ! -- isoln is the cumulative solution number, isgp is the cumulative @@ -419,27 +419,27 @@ subroutine solution_groups_create() sgploop: do ! call parser%GetBlock('SOLUTIONGROUP', isfound, ierr, & - supportOpenClose=.true.) - if(ierr /= 0) exit sgploop + supportOpenClose=.true.) + if (ierr /= 0) exit sgploop if (.not. isfound) exit sgploop isgp = isgp + 1 ! ! -- Get the solutiongroup id and check that it is listed consecutively. sgid = parser%GetInteger() - if(isgp /= sgid) then - write(errmsg, '(a)') 'Solution groups are not listed consecutively.' + if (isgp /= sgid) then + write (errmsg, '(a)') 'Solution groups are not listed consecutively.' call store_error(errmsg) - write(errmsg, '(a,i0,a,i0)' ) 'Found ', sgid, ' when looking for ',isgp + write (errmsg, '(a,i0,a,i0)') 'Found ', sgid, ' when looking for ', isgp call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- Create the solutiongroup and add it to the solutiongrouplist call solutiongroup_create(sgp, sgid) call AddSolutionGroupToList(solutiongrouplist, sgp) ! ! -- Begin processing the solution group - write(iout,'(/1x,a)')'READING SOLUTIONGROUP' + write (iout, '(/1x,a)') 'READING SOLUTIONGROUP' ! ! -- Initialize isgpsoln to 0. isgpsoln is the solution counter for this ! particular solution group. It goes from 1 to the number of solutions @@ -451,126 +451,126 @@ subroutine solution_groups_create() call parser%GetStringCaps(keyword) select case (keyword) ! - case ('MXITER') - sgp%mxiter = parser%GetInteger() + case ('MXITER') + sgp%mxiter = parser%GetInteger() + ! + case ('IMS6') + ! + ! -- Initialize and increment counters + isoln = isoln + 1 + isgpsoln = isgpsoln + 1 ! - case ('IMS6') + ! -- Create the solution, retrieve from the list, and add to sgp + call parser%GetString(fname) + call solution_create(fname, isoln) + sp => GetBaseSolutionFromList(basesolutionlist, isoln) + call sgp%add_solution(isoln, sp) + ! + ! -- Add all of the models that are listed on this line to + ! the current solution (sp) + do + ! + ! -- Set istart and istop to encompass model name. Exit this + ! loop if there are no more models. + call parser%GetStringCaps(mname) + if (mname == '') exit ! - ! -- Initialize and increment counters - isoln = isoln + 1 - isgpsoln = isgpsoln + 1 + ! -- Find the model id, and then get model + mid = ifind(modelname, mname) + if (mid <= 0) then + write (errmsg, '(a,a)') 'Error. Invalid modelname: ', & + trim(mname) + call store_error(errmsg) + call parser%StoreErrorUnit() + end if + mp => GetBaseModelFromList(basemodellist, mid) ! - ! -- Create the solution, retrieve from the list, and add to sgp - call parser%GetString(fname) - call solution_create(fname, isoln) - sp => GetBaseSolutionFromList(basesolutionlist, isoln) - call sgp%add_solution(isoln, sp) + ! -- Add the model to the solution + call sp%add_model(mp) + mp%idsoln = isoln ! - ! -- Add all of the models that are listed on this line to - ! the current solution (sp) - do - ! - ! -- Set istart and istop to encompass model name. Exit this - ! loop if there are no more models. - call parser%GetStringCaps(mname) - if (mname == '') exit - ! - ! -- Find the model id, and then get model - mid = ifind(modelname, mname) - if(mid <= 0) then - write(errmsg, '(a,a)') 'Error. Invalid modelname: ', & - trim(mname) - call store_error(errmsg) - call parser%StoreErrorUnit() - endif - mp => GetBaseModelFromList(basemodellist, mid) - ! - ! -- Add the model to the solution - call sp%add_model(mp) - mp%idsoln = isoln - ! - enddo + end do ! - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SOLUTIONGROUP ENTRY: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SOLUTIONGROUP ENTRY: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do ! ! -- Make sure there is a solution in this solution group - if(isgpsoln == 0) then - write(errmsg, '(4x,a,i0)') & + if (isgpsoln == 0) then + write (errmsg, '(4x,a,i0)') & 'ERROR. THERE ARE NO SOLUTIONS FOR SOLUTION GROUP ', isgp call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- If there is only one solution then mxiter should be 1. - if(isgpsoln == 1 .and. sgp%mxiter > 1) then - write(errmsg, fmterrmxiter) sgp%mxiter, isgpsoln + if (isgpsoln == 1 .and. sgp%mxiter > 1) then + write (errmsg, fmterrmxiter) sgp%mxiter, isgpsoln call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- todo: more error checking? ! - write(iout,'(1x,a)')'END OF SIMULATION SOLUTIONGROUP' + write (iout, '(1x,a)') 'END OF SIMULATION SOLUTIONGROUP' ! - enddo sgploop + end do sgploop ! ! -- Check and make sure at least one solution group was found - if(solutiongrouplist%Count() == 0) then + if (solutiongrouplist%Count() == 0) then call store_error('ERROR. THERE ARE NO SOLUTION GROUPS.') call parser%StoreErrorUnit() - endif + end if ! ! -- return return end subroutine solution_groups_create - !> @brief Check for dangling models, and break with + !> @brief Check for dangling models, and break with !! error when found !< - subroutine check_model_assignment() + subroutine check_model_assignment() character(len=LINELENGTH) :: errmsg class(BaseModelType), pointer :: mp integer(I4B) :: im - + do im = 1, basemodellist%Count() mp => GetBaseModelFromList(basemodellist, im) if (mp%idsoln == 0) then - write(errmsg, '(a,a)') & + write (errmsg, '(a,a)') & '****ERROR. Model was not assigned to a solution: ', mp%name call store_error(errmsg) - endif - enddo + end if + end do if (count_errors() > 0) then call store_error_unit(inunit) - endif + end if end subroutine check_model_assignment !> @brief Assign exchanges to solutions - !! - !! This assigns NumericalExchanges to NumericalSolutions, + !! + !! This assigns NumericalExchanges to NumericalSolutions, !! based on the link between the models in the solution and - !! those exchanges. The BaseExchange%connects_model() function + !! those exchanges. The BaseExchange%connects_model() function !! should be overridden to indicate if such a link exists. !< subroutine assign_exchanges() ! -- local - class(BaseSolutionType), pointer :: sp + class(BaseSolutionType), pointer :: sp class(BaseExchangeType), pointer :: ep - class(BaseModelType), pointer :: mp + class(BaseModelType), pointer :: mp type(ListType), pointer :: models_in_solution integer(I4B) :: is, ie, im do is = 1, basesolutionlist%Count() sp => GetBaseSolutionFromList(basesolutionlist, is) - ! + ! ! -- now loop over exchanges do ie = 1, baseexchangelist%Count() ep => GetBaseExchangeFromList(baseexchangelist, ie) @@ -580,14 +580,14 @@ subroutine assign_exchanges() do im = 1, models_in_solution%Count() mp => GetBaseModelFromList(models_in_solution, im) if (ep%connects_model(mp)) then - ! + ! ! -- add to solution (and only once) call sp%add_exchange(ep) exit end if end do end do - enddo + end do end subroutine assign_exchanges !> @brief Add the model to the list of modelnames, check that the model name is valid @@ -601,35 +601,35 @@ subroutine add_model(im, mtype, mname) integer :: ilen integer :: i character(len=LINELENGTH) :: errmsg - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ im = im + 1 call expandarray(modelname) call parser%GetStringCaps(mname) ilen = len_trim(mname) if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'ERROR. INVALID MODEL NAME: ', trim(mname) + write (errmsg, '(4x,a,a)') & + 'ERROR. INVALID MODEL NAME: ', trim(mname) call store_error(errmsg) - write(errmsg, '(4x,a,i0,a,i0)') & - 'NAME LENGTH OF ', ilen, ' EXCEEDS MAXIMUM LENGTH OF ', & - LENMODELNAME + write (errmsg, '(4x,a,i0,a,i0)') & + 'NAME LENGTH OF ', ilen, ' EXCEEDS MAXIMUM LENGTH OF ', & + LENMODELNAME call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if do i = 1, ilen if (mname(i:i) == ' ') then - write(errmsg, '(4x,a,a)') & - 'ERROR. INVALID MODEL NAME: ', trim(mname) + write (errmsg, '(4x,a,a)') & + 'ERROR. INVALID MODEL NAME: ', trim(mname) call store_error(errmsg) - write(errmsg, '(4x,a)') & - 'MODEL NAME CANNOT HAVE SPACES WITHIN IT.' + write (errmsg, '(4x,a)') & + 'MODEL NAME CANNOT HAVE SPACES WITHIN IT.' call store_error(errmsg) call parser%StoreErrorUnit() - endif - enddo + end if + end do modelname(im) = mname - write(iout, '(4x,a,i0)') mtype // ' model ' // trim(mname) // & - ' will be created as model ', im + write (iout, '(4x,a,i0)') mtype//' model '//trim(mname)// & + ' will be created as model ', im ! ! -- return return diff --git a/src/Timing/ats.f90 b/src/Timing/ats.f90 index db895122e4d..1fca4d34010 100644 --- a/src/Timing/ats.f90 +++ b/src/Timing/ats.f90 @@ -3,7 +3,7 @@ ! Ensure ATS not specified for steady state period ! Add courant time step constraint and other stability controls for GWT model module AdaptiveTimeStepModule - + use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: iout, errmsg, warnmsg use SimModule, only: store_error, count_errors, store_warning @@ -22,20 +22,20 @@ module AdaptiveTimeStepModule public :: ats_cr public :: ats_da - integer(I4B), pointer :: nper => null() !< set equal to nper - integer(I4B), pointer :: maxats => null() !< number of ats entries - real(DP), public, pointer :: dtstable => null() !< delt value required for stability - integer(I4B), dimension(:), pointer, contiguous :: kperats => null() !< array of stress period numbers to apply ats (size NPER) - integer(I4B), dimension(:), pointer, contiguous :: iperats => null() !< array of stress period numbers to apply ats (size MAXATS) - real(DP), dimension(:), pointer, contiguous :: dt0 => null() !< input array of initial time step sizes - real(DP), dimension(:), pointer, contiguous :: dtmin => null() !< input array of minimum time step sizes - real(DP), dimension(:), pointer, contiguous :: dtmax => null() !< input array of maximum time step sizes - real(DP), dimension(:), pointer, contiguous :: dtadj => null() !< input array of time step factors for shortening or increasing - real(DP), dimension(:), pointer, contiguous :: dtfailadj => null() !< input array of time step factors for shortening due to nonconvergence - type(BlockParserType) :: parser !< block parser for reading input file - - contains - + integer(I4B), pointer :: nper => null() !< set equal to nper + integer(I4B), pointer :: maxats => null() !< number of ats entries + real(DP), public, pointer :: dtstable => null() !< delt value required for stability + integer(I4B), dimension(:), pointer, contiguous :: kperats => null() !< array of stress period numbers to apply ats (size NPER) + integer(I4B), dimension(:), pointer, contiguous :: iperats => null() !< array of stress period numbers to apply ats (size MAXATS) + real(DP), dimension(:), pointer, contiguous :: dt0 => null() !< input array of initial time step sizes + real(DP), dimension(:), pointer, contiguous :: dtmin => null() !< input array of minimum time step sizes + real(DP), dimension(:), pointer, contiguous :: dtmax => null() !< input array of maximum time step sizes + real(DP), dimension(:), pointer, contiguous :: dtadj => null() !< input array of time step factors for shortening or increasing + real(DP), dimension(:), pointer, contiguous :: dtfailadj => null() !< input array of time step factors for shortening due to nonconvergence + type(BlockParserType) :: parser !< block parser for reading input file + +contains + !> @ brief Determine if period is adaptive !! !! Check settings and determine if kper is an adaptive @@ -53,7 +53,7 @@ function isAdaptivePeriod(kper) result(lv) end if return end function isAdaptivePeriod - + !> @ brief Create ATS object !! !! Create a new ATS object, and read and check input. @@ -66,7 +66,7 @@ subroutine ats_cr(inunit, nper_tdis) integer(I4B), intent(in) :: nper_tdis ! -- local ! -- formats - character(len=*),parameter :: fmtheader = & + character(len=*), parameter :: fmtheader = & "(1X,/1X,'ATS -- ADAPTIVE TIME STEP PACKAGE,', / & &' VERSION 1 : 03/18/2021 - INPUT READ FROM UNIT ',I0)" ! @@ -74,7 +74,7 @@ subroutine ats_cr(inunit, nper_tdis) call ats_allocate_scalars() ! ! -- Identify package - write(iout, fmtheader) inunit + write (iout, fmtheader) inunit ! ! -- Initialize block parser call parser%initialize(inunit, iout) @@ -110,7 +110,7 @@ end subroutine ats_cr !> @ brief Allocate scalars !! - !! Allocate and initialize scalars for the ATS package. + !! Allocate and initialize scalars for the ATS package. !! !< subroutine ats_allocate_scalars() @@ -130,10 +130,10 @@ subroutine ats_allocate_scalars() ! -- return return end subroutine ats_allocate_scalars - + !> @ brief Allocate arrays !! - !! Allocate and initialize arrays for the ATS package. + !! Allocate and initialize arrays for the ATS package. !! !< subroutine ats_allocate_arrays() @@ -171,7 +171,7 @@ end subroutine ats_allocate_arrays !> @ brief Deallocate variables !! - !! Deallocate all ATS variables. + !! Deallocate all ATS variables. !! !< subroutine ats_da() @@ -197,7 +197,7 @@ end subroutine ats_da !> @ brief Read options !! - !! Read options from ATS input file. + !! Read options from ATS input file. !! !< subroutine ats_read_options() @@ -210,33 +210,33 @@ subroutine ats_read_options() ! ! -- get options block call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING ATS OPTIONS' + write (iout, '(1x,a)') 'PROCESSING ATS OPTIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN ATS OPTION: ', & - trim(keyword) + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN ATS OPTION: ', & + trim(keyword) call store_error(errmsg) call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF ATS OPTIONS' + write (iout, '(1x,a)') 'END OF ATS OPTIONS' end if ! ! -- Return return end subroutine ats_read_options - + !> @ brief Read dimensions !! - !! Read dimensions from ATS input file. + !! Read dimensions from ATS input file. !! !< subroutine ats_read_dimensions() @@ -247,33 +247,33 @@ subroutine ats_read_dimensions() logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtmaxats = & - "(1X,I0,' ADAPTIVE TIME STEP RECORDS(S) WILL FOLLOW IN PERIODDATA')" + &"(1X,I0,' ADAPTIVE TIME STEP RECORDS(S) WILL FOLLOW IN PERIODDATA')" ! ! -- get DIMENSIONS block call parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING ATS DIMENSIONS' + write (iout, '(1x,a)') 'PROCESSING ATS DIMENSIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('MAXATS') - maxats = parser%GetInteger() - write(iout, fmtmaxats) maxats - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN ATS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('MAXATS') + maxats = parser%GetInteger() + write (iout, fmtmaxats) maxats + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN ATS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF ATS DIMENSIONS' + write (iout, '(1x,a)') 'END OF ATS DIMENSIONS' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -281,10 +281,10 @@ subroutine ats_read_dimensions() ! -- Return return end subroutine ats_read_dimensions - + !> @ brief Read timing !! - !! Read timing information from ATS input file. + !! Read timing information from ATS input file. !! !< subroutine ats_read_timing() @@ -298,11 +298,11 @@ subroutine ats_read_timing() ! ! -- get PERIODDATA block call parser%GetBlock('PERIODDATA', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'READING ATS PERIODDATA' + write (iout, '(1x,a)') 'READING ATS PERIODDATA' do n = 1, maxats call parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -314,18 +314,18 @@ subroutine ats_read_timing() dtmax(n) = parser%GetDouble() dtadj(n) = parser%GetDouble() dtfailadj(n) = parser%GetDouble() - enddo + end do ! ! -- Close the block call parser%terminateblock() ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call parser%StoreErrorUnit() - endif - write(iout,'(1x,a)') 'END READING ATS PERIODDATA' + end if + write (iout, '(1x,a)') 'END READING ATS PERIODDATA' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -333,10 +333,10 @@ subroutine ats_read_timing() ! -- Return return end subroutine ats_read_timing - + !> @ brief Process input !! - !! Process ATS input by filling the kperats array. + !! Process ATS input by filling the kperats array. !! !< subroutine ats_process_input() @@ -351,10 +351,10 @@ subroutine ats_process_input() end if end do end subroutine ats_process_input - + !> @ brief Write input table !! - !! Write a table showing the ATS input read from the perioddata block. + !! Write a table showing the ATS input read from the perioddata block. !! !< subroutine ats_input_table() @@ -392,35 +392,35 @@ subroutine ats_input_table() call inputtab%add_term(dtmax(n)) call inputtab%add_term(dtadj(n)) call inputtab%add_term(dtfailadj(n)) - end do + end do ! ! -- deallocate the table call inputtab%table_da() - deallocate(inputtab) - nullify(inputtab) + deallocate (inputtab) + nullify (inputtab) return end subroutine ats_input_table - + !> @ brief Check timing !! !! Perform a check on the input data to make sure values are within - !! required ranges. + !! required ranges. !! !< subroutine ats_check_timing() integer(I4B) :: n - write(iout,'(1x,a)') 'PROCESSING ATS INPUT' + write (iout, '(1x,a)') 'PROCESSING ATS INPUT' do n = 1, maxats ! ! -- check iperats if (iperats(n) < 1) then - write(errmsg, '(a, i0, a, i0)') & + write (errmsg, '(a, i0, a, i0)') & 'IPERATS MUST BE GREATER THAN ZERO. FOUND ', iperats(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) end if if (iperats(n) > nper) then - write(warnmsg, '(a, i0, a, i0)') & + write (warnmsg, '(a, i0, a, i0)') & 'IPERATS GREATER THAN NPER. FOUND ', iperats(n), & ' FOR ATS PERIODDATA RECORD ', n call store_warning(warnmsg) @@ -428,7 +428,7 @@ subroutine ats_check_timing() ! ! -- check dt0 if (dt0(n) < DZERO) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DT0 MUST BE >= ZERO. FOUND ', dt0(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -436,7 +436,7 @@ subroutine ats_check_timing() ! ! -- check dtmin if (dtmin(n) <= DZERO) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTMIN MUST BE > ZERO. FOUND ', dtmin(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -444,7 +444,7 @@ subroutine ats_check_timing() ! ! -- check dtmax if (dtmax(n) <= DZERO) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTMAX MUST BE > ZERO. FOUND ', dtmax(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -452,7 +452,7 @@ subroutine ats_check_timing() ! ! -- check dtmin <= dtmax if (dtmin(n) > dtmax(n)) then - write(errmsg, '(a, 2g15.7, a, i0)') & + write (errmsg, '(a, 2g15.7, a, i0)') & 'DTMIN MUST BE < DTMAX. FOUND ', dtmin(n), dtmax(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -460,7 +460,7 @@ subroutine ats_check_timing() ! ! -- check dtadj if (dtadj(n) .ne. DZERO .and. dtadj(n) < DONE) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTADJ MUST BE 0 or >= 1.0. FOUND ', dtadj(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -468,25 +468,25 @@ subroutine ats_check_timing() ! ! -- check dtfailadj if (dtfailadj(n) .ne. DZERO .and. dtfailadj(n) < DONE) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTFAILADJ MUST BE 0 or >= 1.0. FOUND ', dtfailadj(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) end if - + end do ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call parser%StoreErrorUnit() - endif - write(iout,'(1x,a)') 'DONE PROCESSING ATS INPUT' + end if + write (iout, '(1x,a)') 'DONE PROCESSING ATS INPUT' end subroutine ats_check_timing - + !> @ brief Write period message !! !! Write message to mfsim.lst file with information on ATS settings - !! for this period. + !! for this period. !! !< subroutine ats_period_message(kper) @@ -494,7 +494,7 @@ subroutine ats_period_message(kper) integer(I4B), intent(in) :: kper ! -- local integer(I4B) :: n - character(len=*),parameter :: fmtspts = & + character(len=*), parameter :: fmtspts = & "(28X,'ATS IS OVERRIDING TIME STEPPING FOR THIS PERIOD',/ & &28X,'INITIAL TIME STEP SIZE (DT0) = ',G15.7,/ & &28X,'MINIMUM TIME STEP SIZE (DTMIN) = ',G15.7,/ & @@ -503,10 +503,10 @@ subroutine ats_period_message(kper) &28X,'DIVIDER FOR FAILED TIME STEP (DTFAILADJ) = ',G15.7,/ & &)" n = kperats(kper) - write(iout, fmtspts) dt0(n), dtmin(n), dtmax(n), dtadj(n), dtfailadj(n) + write (iout, fmtspts) dt0(n), dtmin(n), dtmax(n), dtadj(n), dtfailadj(n) return end subroutine ats_period_message - + !> @ brief Allow and external caller to submit preferred time step !! !! Submit a preferred time step length. Alternatively, if idir is @@ -524,9 +524,9 @@ subroutine ats_submit_delt(kstp, kper, dt, sloc, idir) integer(I4B) :: n real(DP) :: tsfact real(DP) :: dt_temp - character(len=*), parameter :: fmtdtsubmit = & + character(len=*), parameter :: fmtdtsubmit = & &"(1x, 'ATS: ', A,' submitted a preferred time step size of ', G15.7)" - + if (isAdaptivePeriod(kper)) then n = kperats(kper) tsfact = dtadj(n) @@ -546,7 +546,7 @@ subroutine ats_submit_delt(kstp, kper, dt, sloc, idir) dt_temp = dt end if if (kstp > 1 .and. dt_temp > DZERO) then - write(iout, fmtdtsubmit) trim(adjustl(sloc)), dt_temp + write (iout, fmtdtsubmit) trim(adjustl(sloc)), dt_temp end if if (dt_temp > DZERO .and. dt_temp < dtstable) then ! -- Reset dtstable to a smaller value @@ -556,7 +556,7 @@ subroutine ats_submit_delt(kstp, kper, dt, sloc, idir) end if return end subroutine ats_submit_delt - + !> @ brief Set time step !! !! Set the time step length (delt) for this time step using the ATS @@ -575,8 +575,8 @@ subroutine ats_set_delt(kstp, kper, pertim, perlencurrent, delt) integer(I4B) :: n real(DP) :: tstart ! -- formats - character(len=*), parameter :: fmtdt = & - &"(1x, 'ATS: time step set to ', G15.7, ' for step ', i0, & + character(len=*), parameter :: fmtdt = & + "(1x, 'ATS: time step set to ', G15.7, ' for step ', i0, & &' and period ', i0)" ! ! -- initialize the record position (n) for this stress period @@ -588,7 +588,7 @@ subroutine ats_set_delt(kstp, kper, pertim, perlencurrent, delt) ! -- Calculate delt ! ! -- Setup new stress period if kstp is 1 - if(kstp == 1) then + if (kstp == 1) then ! ! -- Assign first value of delt for this stress period if (dt0(n) /= DZERO) then @@ -619,11 +619,11 @@ subroutine ats_set_delt(kstp, kper, pertim, perlencurrent, delt) end if ! ! -- Write time step size information - write(iout, fmtdt) delt, kstp, kper + write (iout, fmtdt) delt, kstp, kper ! return end subroutine ats_set_delt - + !> @ brief Reset time step because failure has occurred !! !! Reset the time step using dtfailadj because the time step @@ -643,7 +643,7 @@ subroutine ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) real(DP) :: delt_temp real(DP) :: tsfact ! -- formats - character(len=*),parameter :: fmttsi = & + character(len=*), parameter :: fmttsi = & "(1X, 'Failed solution for step ', i0, ' and period ', i0, & &' will be retried using time step of ', G15.7)" if (isAdaptivePeriod(kper)) then @@ -656,15 +656,15 @@ subroutine ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) if (delt_temp >= dtmin(n)) then finishedTrying = .false. delt = delt_temp - write(iout, fmttsi) kstp, kper, delt + write (iout, fmttsi) kstp, kper, delt end if end if - + end if end if return end subroutine ats_reset_delt - + !> @ brief Set end of period indicator !! !! Determine if it is the end of the stress period and set the endofperiod @@ -679,12 +679,12 @@ subroutine ats_set_endofperiod(kper, pertim, perlencurrent, endofperiod) ! -- local integer(I4B) :: n ! - ! -- End of stress period and/or simulation? + ! -- End of stress period and/or simulation? n = kperats(kper) if (abs(pertim - perlencurrent) < dtmin(n)) then endofperiod = .true. end if return end subroutine ats_set_endofperiod - -end module AdaptiveTimeStepModule \ No newline at end of file + +end module AdaptiveTimeStepModule diff --git a/src/Timing/tdis.f90 b/src/Timing/tdis.f90 index ad09a2b99cb..01c631ac8fd 100644 --- a/src/Timing/tdis.f90 +++ b/src/Timing/tdis.f90 @@ -2,7 +2,7 @@ !convert this to a derived type? May not be necessary since only !one of them is needed. - module TdisModule +module TdisModule use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: iout @@ -19,30 +19,30 @@ module TdisModule public :: tdis_ot public :: tdis_da ! - integer(I4B), public, pointer :: nper => null() !< number of stress period - integer(I4B), public, pointer :: itmuni => null() !< flag indicating time units - integer(I4B), public, pointer :: kper => null() !< current stress period number - integer(I4B), public, pointer :: kstp => null() !< current time step number - integer(I4B), public, pointer :: inats => null() !< flag indicating ats active for simulation - logical(LGP), public, pointer :: readnewdata => null() !< flag indicating time to read new data - logical(LGP), public, pointer :: endofperiod => null() !< flag indicating end of stress period - logical(LGP), public, pointer :: endofsimulation => null() !< flag indicating end of simulation - real(DP), public, pointer :: delt => null() !< length of the current time step - real(DP), public, pointer :: pertim => null() !< time relative to start of stress period - real(DP), public, pointer :: totim => null() !< time relative to start of simulation - real(DP), public, pointer :: totimc => null() !< simulation time at start of time step - real(DP), public, pointer :: deltsav => null() !< saved value for delt, used for subtiming - real(DP), public, pointer :: totimsav => null() !< saved value for totim, used for subtiming - real(DP), public, pointer :: pertimsav => null() !< saved value for pertim, used for subtiming - real(DP), public, pointer :: totalsimtime => null() !< time at end of simulation - real(DP), public, dimension(:), pointer, contiguous :: perlen => null() !< length of each stress period - integer(I4B), public, dimension(:), pointer, contiguous :: nstp => null() !< number of time steps in each stress period - real(DP), public, dimension(:), pointer, contiguous :: tsmult => null() !< time step multiplier for each stress period - character(len=LENDATETIME), pointer :: datetime0 => null() !< starting date and time for the simulation + integer(I4B), public, pointer :: nper => null() !< number of stress period + integer(I4B), public, pointer :: itmuni => null() !< flag indicating time units + integer(I4B), public, pointer :: kper => null() !< current stress period number + integer(I4B), public, pointer :: kstp => null() !< current time step number + integer(I4B), public, pointer :: inats => null() !< flag indicating ats active for simulation + logical(LGP), public, pointer :: readnewdata => null() !< flag indicating time to read new data + logical(LGP), public, pointer :: endofperiod => null() !< flag indicating end of stress period + logical(LGP), public, pointer :: endofsimulation => null() !< flag indicating end of simulation + real(DP), public, pointer :: delt => null() !< length of the current time step + real(DP), public, pointer :: pertim => null() !< time relative to start of stress period + real(DP), public, pointer :: totim => null() !< time relative to start of simulation + real(DP), public, pointer :: totimc => null() !< simulation time at start of time step + real(DP), public, pointer :: deltsav => null() !< saved value for delt, used for subtiming + real(DP), public, pointer :: totimsav => null() !< saved value for totim, used for subtiming + real(DP), public, pointer :: pertimsav => null() !< saved value for pertim, used for subtiming + real(DP), public, pointer :: totalsimtime => null() !< time at end of simulation + real(DP), public, dimension(:), pointer, contiguous :: perlen => null() !< length of each stress period + integer(I4B), public, dimension(:), pointer, contiguous :: nstp => null() !< number of time steps in each stress period + real(DP), public, dimension(:), pointer, contiguous :: tsmult => null() !< time step multiplier for each stress period + character(len=LENDATETIME), pointer :: datetime0 => null() !< starting date and time for the simulation ! type(BlockParserType), private :: parser - contains +contains subroutine tdis_cr(fname) ! ****************************************************************************** @@ -60,7 +60,7 @@ subroutine tdis_cr(fname) ! -- local integer(I4B) :: inunit ! -- formats - character(len=*),parameter :: fmtheader = & + character(len=*), parameter :: fmtheader = & "(1X,/1X,'TDIS -- TEMPORAL DISCRETIZATION PACKAGE,', / & &' VERSION 1 : 11/13/2014 - INPUT READ FROM UNIT ',I4)" ! ------------------------------------------------------------------------------ @@ -69,14 +69,14 @@ subroutine tdis_cr(fname) call tdis_allocate_scalars() ! ! -- Get a unit number for tdis and open the file if it is not opened - inquire(file=fname, number=inunit) - if(inunit < 0) then + inquire (file=fname, number=inunit) + if (inunit < 0) then inunit = getunit() call openfile(inunit, iout, fname, 'TDIS') - endif + end if ! ! -- Identify package - write(iout, fmtheader) inunit + write (iout, fmtheader) inunit ! ! -- Initialize block parser call parser%Initialize(inunit, iout) @@ -113,23 +113,23 @@ subroutine tdis_set_counters() use ConstantsModule, only: DONE, DZERO, MNORMAL, MVALIDATE, DNODATA use SimVariablesModule, only: isim_mode use GenericUtilitiesModule, only: sim_message - use AdaptiveTimeStepModule, only: isAdaptivePeriod, dtstable, & + use AdaptiveTimeStepModule, only: isAdaptivePeriod, dtstable, & ats_period_message ! -- local character(len=LINELENGTH) :: line character(len=4) :: cpref character(len=10) :: cend ! -- formats - character(len=*),parameter :: fmtspts = & - "(a, 'Solving: Stress period: ',i5,4x, 'Time step: ',i5,4x, a)" - character(len=*),parameter :: fmtvspts = & - "(' Validating: Stress period: ',i5,4x,'Time step: ',i5,4x)" - character(len=*),parameter :: fmtspi = & - "('1',/28X,'STRESS PERIOD NO. ',I0,', LENGTH =',G15.7,/ & - &28X,47('-'))" - character(len=*),parameter :: fmtspits = & - "(28X,'NUMBER OF TIME STEPS = ',I0,/ & - &28X,'MULTIPLIER FOR DELT =',F10.3)" + character(len=*), parameter :: fmtspts = & + &"(a, 'Solving: Stress period: ',i5,4x, 'Time step: ',i5,4x, a)" + character(len=*), parameter :: fmtvspts = & + &"(' Validating: Stress period: ',i5,4x,'Time step: ',i5,4x)" + character(len=*), parameter :: fmtspi = & + "('1',/28X,'STRESS PERIOD NO. ',I0,', LENGTH =',G15.7,/ & + &28X,47('-'))" + character(len=*), parameter :: fmtspits = & + "(28X,'NUMBER OF TIME STEPS = ',I0,/ & + &28X,'MULTIPLIER FOR DELT =',F10.3)" ! ------------------------------------------------------------------------------ ! ! -- Initialize variables for this step @@ -148,29 +148,29 @@ subroutine tdis_set_counters() end if ! ! -- Print stress period and time step to console - select case(isim_mode) - case(MVALIDATE) - write(line, fmtvspts) kper, kstp - case(MNORMAL) - write(line, fmtspts) cpref, kper, kstp, trim(cend) + select case (isim_mode) + case (MVALIDATE) + write (line, fmtvspts) kper, kstp + case (MNORMAL) + write (line, fmtspts) cpref, kper, kstp, trim(cend) end select call sim_message(line, level=VALL) call sim_message(line, iunit=iout, skipbefore=1, skipafter=1) ! ! -- Write message if first time step if (kstp == 1) then - write(iout, fmtspi) kper, perlen(kper) + write (iout, fmtspi) kper, perlen(kper) if (isAdaptivePeriod(kper)) then call ats_period_message(kper) else - write(iout, fmtspits) nstp(kper), tsmult(kper) + write (iout, fmtspits) nstp(kper), tsmult(kper) end if end if ! ! -- return return end subroutine tdis_set_counters - + subroutine tdis_set_timestep() ! ****************************************************************************** ! tdis_set_timestep -- Set time step length @@ -186,8 +186,8 @@ subroutine tdis_set_timestep() ! -- local logical(LGP) :: adaptivePeriod ! -- format - character(len=*), parameter :: fmttsi = & - "(28X,'INITIAL TIME STEP SIZE =',G15.7)" + character(len=*), parameter :: fmttsi = & + "(28X,'INITIAL TIME STEP SIZE =',G15.7)" ! ------------------------------------------------------------------------------ ! ! -- Initialize @@ -202,7 +202,7 @@ subroutine tdis_set_timestep() else call tdis_set_delt() if (kstp == 1) then - write(iout, fmttsi) delt + write (iout, fmttsi) delt end if end if ! @@ -227,7 +227,7 @@ subroutine tdis_set_timestep() end if ! ! -- Set end of simulation indicator - if (endofperiod .and. kper==nper) then + if (endofperiod .and. kper == nper) then endofsimulation = .true. totim = totalsimtime end if @@ -240,7 +240,7 @@ subroutine tdis_delt_reset(deltnew) ! ****************************************************************************** ! tdis_delt_reset -- reset delt and update timing variables and indicators. ! This routine is called when a timestep fails to converge, and so it is -! retried using a smaller time step (deltnew). +! retried using a smaller time step (deltnew). ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -273,7 +273,7 @@ subroutine tdis_delt_reset(deltnew) end if ! ! -- Set end of simulation indicator - if (endofperiod .and. kper==nper) then + if (endofperiod .and. kper == nper) then endofsimulation = .true. totim = totalsimtime end if @@ -294,11 +294,11 @@ subroutine tdis_set_delt() ! -- local ! ------------------------------------------------------------------------------ ! - if(kstp == 1) then + if (kstp == 1) then delt = perlen(kper) / float(nstp(kper)) - if(tsmult(kper) /= DONE) & - delt = perlen(kper) * (DONE-tsmult(kper)) / & - (DONE - tsmult(kper) ** nstp(kper)) + if (tsmult(kper) /= DONE) & + delt = perlen(kper) * (DONE - tsmult(kper)) / & + (DONE - tsmult(kper)**nstp(kper)) else delt = tsmult(kper) * delt end if @@ -317,7 +317,7 @@ end subroutine tdis_set_delt ! ! -- modules ! use ConstantsModule, only: DONE, DZERO ! ! -- formats -! character(len=*),parameter :: fmttsi = & +! character(len=*),parameter :: fmttsi = & ! "(28X,'INITIAL TIME STEP SIZE =',G15.7)" !! ------------------------------------------------------------------------------ ! ! @@ -326,8 +326,8 @@ end subroutine tdis_set_delt ! ! ! ! -- Calculate the first value of delt for this stress period ! delt = perlen(kper) / float(nstp(kper)) -! if(tsmult(kper) /= DONE) & -! delt = perlen(kper) * (DONE-tsmult(kper)) / & +! if(tsmult(kper) /= DONE) & +! delt = perlen(kper) * (DONE-tsmult(kper)) / & ! (DONE - tsmult(kper) ** nstp(kper)) ! ! ! ! -- Print length of first time step @@ -360,7 +360,7 @@ end subroutine tdis_set_delt ! end if ! if (endofperiod .and. kper==nper) then ! endofsimulation = .true. -! totim = totalsimtime +! totim = totalsimtime ! end if ! ! ! ! -- return @@ -374,73 +374,73 @@ subroutine tdis_ot(iout) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: iout - ! -- local - real(DP) :: zero,cnv,delsec,totsec,persec,sixty,hrday,dayyr, & - delmn,delhr,totmn,tothr,totdy,totyr,permn,perhr,perdy, & - peryr,deldy,delyr + ! -- dummy + integer(I4B), intent(in) :: iout + ! -- local + real(DP) :: zero, cnv, delsec, totsec, persec, sixty, hrday, dayyr, & + delmn, delhr, totmn, tothr, totdy, totyr, permn, perhr, & + perdy, peryr, deldy, delyr ! ------------------------------------------------------------------------------ - WRITE(IOUT,199) KSTP,KPER - 199 FORMAT(1X,///9X,'TIME SUMMARY AT END OF TIME STEP',I5, & - & ' IN STRESS PERIOD ',I4) + WRITE (IOUT, 199) KSTP, KPER +199 FORMAT(1X, ///9X, 'TIME SUMMARY AT END OF TIME STEP', I5, & + & ' IN STRESS PERIOD ', I4) !C !C1------USE TIME UNIT INDICATOR TO GET FACTOR TO CONVERT TO SECONDS. - ZERO=0.d0 - CNV=ZERO - IF(ITMUNI.EQ.1) CNV=1. - IF(ITMUNI.EQ.2) CNV=60. - IF(ITMUNI.EQ.3) CNV=3600. - IF(ITMUNI.EQ.4) CNV=86400. - IF(ITMUNI.EQ.5) CNV=31557600. + ZERO = 0.d0 + CNV = ZERO + IF (ITMUNI .EQ. 1) CNV = 1. + IF (ITMUNI .EQ. 2) CNV = 60. + IF (ITMUNI .EQ. 3) CNV = 3600. + IF (ITMUNI .EQ. 4) CNV = 86400. + IF (ITMUNI .EQ. 5) CNV = 31557600. !C !C2------IF FACTOR=0 THEN TIME UNITS ARE NON-STANDARD. - IF(CNV.NE.ZERO) GO TO 100 + IF (CNV .NE. ZERO) GO TO 100 !C !C2A-----PRINT TIMES IN NON-STANDARD TIME UNITS. - WRITE(IOUT,301) DELT,PERTIM,TOTIM - 301 FORMAT(21X,' TIME STEP LENGTH =',G15.6/ & - & 21X,' STRESS PERIOD TIME =',G15.6/ & - & 21X,'TOTAL SIMULATION TIME =',G15.6) + WRITE (IOUT, 301) DELT, PERTIM, TOTIM +301 FORMAT(21X, ' TIME STEP LENGTH =', G15.6 / & + & 21X, ' STRESS PERIOD TIME =', G15.6 / & + & 21X, 'TOTAL SIMULATION TIME =', G15.6) !C !C2B-----RETURN - RETURN + RETURN !C !C3------CALCULATE LENGTH OF TIME STEP & ELAPSED TIMES IN SECONDS. - 100 DELSEC=CNV*DELT - TOTSEC=CNV*TOTIM - PERSEC=CNV*PERTIM +100 DELSEC = CNV * DELT + TOTSEC = CNV * TOTIM + PERSEC = CNV * PERTIM !C !C4------CALCULATE TIMES IN MINUTES,HOURS,DAYS AND YEARS. - SIXTY=60. - HRDAY=24. - DAYYR=365.25 - DELMN=DELSEC/SIXTY - DELHR=DELMN/SIXTY - DELDY=DELHR/HRDAY - DELYR=DELDY/DAYYR - TOTMN=TOTSEC/SIXTY - TOTHR=TOTMN/SIXTY - TOTDY=TOTHR/HRDAY - TOTYR=TOTDY/DAYYR - PERMN=PERSEC/SIXTY - PERHR=PERMN/SIXTY - PERDY=PERHR/HRDAY - PERYR=PERDY/DAYYR + SIXTY = 60. + HRDAY = 24. + DAYYR = 365.25 + DELMN = DELSEC / SIXTY + DELHR = DELMN / SIXTY + DELDY = DELHR / HRDAY + DELYR = DELDY / DAYYR + TOTMN = TOTSEC / SIXTY + TOTHR = TOTMN / SIXTY + TOTDY = TOTHR / HRDAY + TOTYR = TOTDY / DAYYR + PERMN = PERSEC / SIXTY + PERHR = PERMN / SIXTY + PERDY = PERHR / HRDAY + PERYR = PERDY / DAYYR !C !C5------PRINT TIME STEP LENGTH AND ELAPSED TIMES IN ALL TIME UNITS. - WRITE(IOUT,200) - 200 FORMAT(19X,' SECONDS MINUTES HOURS',7X, & - & 'DAYS YEARS'/20X,59('-')) - write(IOUT,201) DELSEC,DELMN,DELHR,DELDY,DELYR - 201 FORMAT(1X,' TIME STEP LENGTH',1P,5G12.5) - WRITE(IOUT,202) PERSEC,PERMN,PERHR,PERDY,PERYR - 202 FORMAT(1X,'STRESS PERIOD TIME',1P,5G12.5) - WRITE(IOUT,203) TOTSEC,TOTMN,TOTHR,TOTDY,TOTYR - 203 FORMAT(1X,' TOTAL TIME',1P,5G12.5,/) + WRITE (IOUT, 200) +200 FORMAT(19X, ' SECONDS MINUTES HOURS', 7X, & + & 'DAYS YEARS'/20X, 59('-')) + write (IOUT, 201) DELSEC, DELMN, DELHR, DELDY, DELYR +201 FORMAT(1X, ' TIME STEP LENGTH', 1P, 5G12.5) + WRITE (IOUT, 202) PERSEC, PERMN, PERHR, PERDY, PERYR +202 FORMAT(1X, 'STRESS PERIOD TIME', 1P, 5G12.5) + WRITE (IOUT, 203) TOTSEC, TOTMN, TOTHR, TOTDY, TOTYR +203 FORMAT(1X, ' TOTAL TIME', 1P, 5G12.5,/) !C !C6------RETURN - RETURN + RETURN END subroutine tdis_ot subroutine tdis_da() @@ -475,7 +475,7 @@ subroutine tdis_da() call mem_deallocate(totalsimtime) ! ! -- strings - deallocate(datetime0) + deallocate (datetime0) ! ! -- Arrays call mem_deallocate(perlen) @@ -486,7 +486,6 @@ subroutine tdis_da() return end subroutine tdis_da - subroutine tdis_read_options() ! ****************************************************************************** ! tdis_read_options -- Read the options @@ -505,9 +504,9 @@ subroutine tdis_read_options() logical :: undspec ! -- formats character(len=*), parameter :: fmtitmuni = & - "(4x,'SIMULATION TIME UNIT IS ',A)" + &"(4x,'SIMULATION TIME UNIT IS ',A)" character(len=*), parameter :: fmtdatetime0 = & - "(4x,'SIMULATION STARTING DATE AND TIME IS ',A)" + &"(4x,'SIMULATION STARTING DATE AND TIME IS ',A)" !data ! ------------------------------------------------------------------------------ ! @@ -517,11 +516,11 @@ subroutine tdis_read_options() ! ! -- get options block call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS OPTIONS' + write (iout, '(1x,a)') 'PROCESSING TDIS OPTIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -530,60 +529,60 @@ subroutine tdis_read_options() case ('TIME_UNITS') call parser%GetStringCaps(keyword) select case (keyword) - case('UNDEFINED') + case ('UNDEFINED') itmuni = 0 - write(iout, fmtitmuni) 'UNDEFINED' + write (iout, fmtitmuni) 'UNDEFINED' undspec = .true. - case('SECONDS') + case ('SECONDS') itmuni = 1 - write(iout, fmtitmuni) 'SECONDS' - case('MINUTES') + write (iout, fmtitmuni) 'SECONDS' + case ('MINUTES') itmuni = 2 - write(iout, fmtitmuni) 'MINUTES' - case('HOURS') + write (iout, fmtitmuni) 'MINUTES' + case ('HOURS') itmuni = 3 - write(iout, fmtitmuni) 'HOURS' - case('DAYS') + write (iout, fmtitmuni) 'HOURS' + case ('DAYS') itmuni = 4 - write(iout, fmtitmuni) 'DAYS' - case('YEARS') + write (iout, fmtitmuni) 'DAYS' + case ('YEARS') itmuni = 5 - write(iout, fmtitmuni) 'YEARS' + write (iout, fmtitmuni) 'YEARS' case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TIME_UNITS: ', & - trim(keyword) + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN TIME_UNITS: ', & + trim(keyword) call store_error(errmsg) call parser%StoreErrorUnit() end select case ('START_DATE_TIME') call parser%GetString(datetime0) - write(iout, fmtdatetime0) datetime0 + write (iout, fmtdatetime0) datetime0 case ('ATS6') call parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'ATS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'ATS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' call store_error(errmsg) - endif + end if call parser%GetString(fname) inats = GetUnit() call openfile(inats, iout, fname, 'ATS') case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS OPTION: ', & - trim(keyword) + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN TDIS OPTION: ', & + trim(keyword) call store_error(errmsg) call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF TDIS OPTIONS' + write (iout, '(1x,a)') 'END OF TDIS OPTIONS' end if ! ! -- Set to itmuni to undefined if not specified - if(itmuni == 0) then - if(.not. undspec) then - write(iout, fmtitmuni) 'UNDEFINED' - endif - endif + if (itmuni == 0) then + if (.not. undspec) then + write (iout, fmtitmuni) 'UNDEFINED' + end if + end if ! ! -- Return return @@ -620,7 +619,7 @@ subroutine tdis_allocate_scalars() call mem_allocate(totalsimtime, 'TOTALSIMTIME', 'TDIS') ! ! -- strings - allocate(datetime0) + allocate (datetime0) ! ! -- Initialize variables nper = 0 @@ -645,7 +644,6 @@ subroutine tdis_allocate_scalars() return end subroutine tdis_allocate_scalars - subroutine tdis_allocate_arrays() ! ****************************************************************************** ! tdis_allocate_arrays -- Allocate tdis arrays @@ -681,35 +679,35 @@ subroutine tdis_read_dimensions() logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtnper = & - "(1X,I4,' STRESS PERIOD(S) IN SIMULATION')" + "(1X,I4,' STRESS PERIOD(S) IN SIMULATION')" !data ! ------------------------------------------------------------------------------ ! ! -- get DIMENSIONS block call parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS DIMENSIONS' + write (iout, '(1x,a)') 'PROCESSING TDIS DIMENSIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('NPER') - nper = parser%GetInteger() - write(iout, fmtnper) nper - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('NPER') + nper = parser%GetInteger() + write (iout, fmtnper) nper + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN TDIS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF TDIS DIMENSIONS' + write (iout, '(1x,a)') 'END OF TDIS DIMENSIONS' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -734,41 +732,41 @@ subroutine tdis_read_timing() integer(I4B) :: n logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtheader = & - "(1X,//1X,'STRESS PERIOD LENGTH TIME STEPS', & + character(len=*), parameter :: fmtheader = & + "(1X,//1X,'STRESS PERIOD LENGTH TIME STEPS', & &' MULTIPLIER FOR DELT',/1X,76('-'))" - character(len=*), parameter :: fmtrow = & - "(1X,I8,1PG21.7,I7,0PF25.3)" + character(len=*), parameter :: fmtrow = & + "(1X,I8,1PG21.7,I7,0PF25.3)" ! ------------------------------------------------------------------------------ ! ! -- get PERIODDATA block call parser%GetBlock('PERIODDATA', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS PERIODDATA' - write(iout, fmtheader) + write (iout, '(1x,a)') 'PROCESSING TDIS PERIODDATA' + write (iout, fmtheader) do n = 1, nper call parser%GetNextLine(endOfBlock) perlen(n) = parser%GetDouble() nstp(n) = parser%GetInteger() tsmult(n) = parser%GetDouble() - write(iout, fmtrow) n, perlen(n), nstp(n), tsmult(n) + write (iout, fmtrow) n, perlen(n), nstp(n), tsmult(n) totalsimtime = totalsimtime + perlen(n) - enddo + end do ! ! -- Check timing information call check_tdis_timing(nper, perlen, nstp, tsmult) call parser%terminateblock() ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call parser%StoreErrorUnit() - endif - write(iout,'(1x,a)') 'END OF TDIS PERIODDATA' + end if + write (iout, '(1x,a)') 'END OF TDIS PERIODDATA' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -776,10 +774,10 @@ subroutine tdis_read_timing() ! -- Return return end subroutine tdis_read_timing - + subroutine check_tdis_timing(nper, perlen, nstp, tsmult) ! ****************************************************************************** -! check_tdis_timing -- Check the tdis timing information. Return back to +! check_tdis_timing -- Check the tdis timing information. Return back to ! tdis_read_timing if an error condition is found and let the ustop ! routine be called there instead so the StoreErrorUnit routine can be ! called to assign the correct file name. @@ -800,13 +798,13 @@ subroutine check_tdis_timing(nper, perlen, nstp, tsmult) real(DP) :: tstart, tend, dt character(len=LINELENGTH) :: errmsg ! -- formats - character(len=*), parameter :: fmtpwarn = & - &"(1X,/1X,'PERLEN IS ZERO FOR STRESS PERIOD ', I0, & + character(len=*), parameter :: fmtpwarn = & + "(1X,/1X,'PERLEN IS ZERO FOR STRESS PERIOD ', I0, & &'. PERLEN MUST NOT BE ZERO FOR TRANSIENT PERIODS.')" - character(len=*), parameter :: fmtsperror = & + character(len=*), parameter :: fmtsperror = & &"(A,' FOR STRESS PERIOD ', I0)" - character(len=*), parameter :: fmtdterror = & - &"('TIME STEP LENGTH OF ', G0, ' IS TOO SMALL IN PERIOD ', I0, & + character(len=*), parameter :: fmtdterror = & + "('TIME STEP LENGTH OF ', G0, ' IS TOO SMALL IN PERIOD ', I0, & &' AND TIME STEP ', I0)" ! ------------------------------------------------------------------------------ ! @@ -817,28 +815,28 @@ subroutine check_tdis_timing(nper, perlen, nstp, tsmult) do kper = 1, nper ! ! -- Error if nstp less than or equal to zero - if(nstp(kper) <= 0) then - write(errmsg, fmtsperror) 'NUMBER OF TIME STEPS LESS THAN ONE ', kper + if (nstp(kper) <= 0) then + write (errmsg, fmtsperror) 'NUMBER OF TIME STEPS LESS THAN ONE ', kper call store_error(errmsg) return end if ! ! -- Warn if perlen is zero - if(perlen(kper) == DZERO) then - write(iout, fmtpwarn) kper - return + if (perlen(kper) == DZERO) then + write (iout, fmtpwarn) kper + return end if ! ! -- Error if tsmult is less than zero - if(tsmult(kper) <= DZERO) then - write(errmsg, fmtsperror) 'TSMULT MUST BE GREATER THAN 0.0 ', kper + if (tsmult(kper) <= DZERO) then + write (errmsg, fmtsperror) 'TSMULT MUST BE GREATER THAN 0.0 ', kper call store_error(errmsg) return end if ! ! -- Error if negative period length - if(perlen(kper) < DZERO) then - write(errmsg, fmtsperror) 'PERLEN CANNOT BE LESS THAN 0.0 ', kper + if (perlen(kper) < DZERO) then + write (errmsg, fmtsperror) 'PERLEN CANNOT BE LESS THAN 0.0 ', kper call store_error(errmsg) return end if @@ -847,26 +845,26 @@ subroutine check_tdis_timing(nper, perlen, nstp, tsmult) do kstp = 1, nstp(kper) if (kstp == 1) then dt = perlen(kper) / float(nstp(kper)) - if(tsmult(kper) /= DONE) & - dt = perlen(kper) * (DONE-tsmult(kper)) / & - (DONE - tsmult(kper) ** nstp(kper)) + if (tsmult(kper) /= DONE) & + dt = perlen(kper) * (DONE - tsmult(kper)) / & + (DONE - tsmult(kper)**nstp(kper)) else dt = dt * tsmult(kper) - endif + end if tend = tstart + dt ! ! -- Error condition if tstart == tend if (tstart == tend) then - write(errmsg, fmtdterror) dt, kper, kstp + write (errmsg, fmtdterror) dt, kper, kstp call store_error(errmsg) return - endif - enddo + end if + end do ! ! -- reset tstart = tend tstart = tend ! - enddo + end do ! -- Return return end subroutine check_tdis_timing diff --git a/src/Utilities/ArrayHandlers.f90 b/src/Utilities/ArrayHandlers.f90 index f2aa62a396c..7759fb1f9ab 100644 --- a/src/Utilities/ArrayHandlers.f90 +++ b/src/Utilities/ArrayHandlers.f90 @@ -8,7 +8,7 @@ module ArrayHandlersModule public :: ExpandArray, ExpandArrayWrapper, ExtendPtrArray public :: ifind public :: remove_character - + interface ExpandArrayWrapper module procedure expand_integer_wrapper end interface @@ -18,8 +18,8 @@ module ArrayHandlersModule ! IMPORTANT: Do not use pointers to elements of arrays when using ! ExpandArray to increase the array size! The locations of array ! elements in memory are changed when ExpandArray is invoked. - module procedure expand_integer, expand_double, & - expand_character !, expand_real + module procedure expand_integer, expand_double, & + expand_character !, expand_real end interface ExpandArray interface ExtendPtrArray @@ -70,11 +70,11 @@ subroutine expand_integer_wrapper(nsize, array, minvalue, loginc) if (loginc) then increment = int(log10(real(nsize, DP)), I4B) increment = int(DTEN**increment, I4B) - ! - ! -- increase increment by a multiplier and a value no - ! smaller than a default or specified minimum size + ! + ! -- increase increment by a multiplier and a value no + ! smaller than a default or specified minimum size else - increment = int(nsize * 0.2_DP) + increment = int(nsize * 0.2_DP) increment = max(minimum_increment, increment) end if ! @@ -97,7 +97,7 @@ subroutine expand_integer(array, increment) implicit none ! -- dummy integer(I4B), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment + integer(I4B), optional, intent(in) :: increment ! -- local integer(I4B) :: inclocal, isize, newsize integer(I4B), allocatable, dimension(:) :: array_temp @@ -107,20 +107,20 @@ subroutine expand_integer(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (allocated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize)) + allocate (array_temp(newsize)) array_temp(1:isize) = array - deallocate(array) + deallocate (array) call move_alloc(array_temp, array) else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! return end subroutine expand_integer @@ -129,7 +129,7 @@ subroutine expand_double(array, increment) implicit none ! -- dummy real(DP), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment + integer(I4B), optional, intent(in) :: increment ! -- local integer(I4B) :: inclocal, isize, newsize real(DP), allocatable, dimension(:) :: array_temp @@ -139,20 +139,20 @@ subroutine expand_double(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (allocated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize)) + allocate (array_temp(newsize)) array_temp(1:isize) = array - deallocate(array) + deallocate (array) call move_alloc(array_temp, array) else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! return end subroutine expand_double @@ -161,7 +161,7 @@ subroutine expand_character(array, increment) implicit none ! -- dummy character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment + integer(I4B), optional, intent(in) :: increment ! -- local character(len=LINELENGTH) :: line character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp @@ -172,13 +172,13 @@ subroutine expand_character(array, increment) ! -- check character length lenc = len(array) if (lenc > MAXCHARLEN) then - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Need to increase MAXCHARLEN' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Need to increase MAXCHARLEN' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) @@ -189,7 +189,7 @@ subroutine expand_character(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data @@ -198,22 +198,22 @@ subroutine expand_character(array, increment) if (allocated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(isize)) - do i=1,isize + allocate (array_temp(isize)) + do i = 1, isize array_temp(i) = array(i) - enddo - deallocate(array) - allocate(array(newsize)) - do i=1,isize + end do + deallocate (array) + allocate (array(newsize)) + do i = 1, isize array(i) = array_temp(i) - enddo - do i=isize+1,newsize + end do + do i = isize + 1, newsize array(i) = '' - enddo - deallocate(array_temp) + end do + deallocate (array_temp) else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! return end subroutine expand_character @@ -238,32 +238,32 @@ subroutine extend_double(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (associated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize), stat=istat, errmsg=ermsg) + allocate (array_temp(newsize), stat=istat, errmsg=ermsg) if (istat /= 0) goto 99 - do i=1,isize + do i = 1, isize array_temp(i) = array(i) - enddo - deallocate(array) + end do + deallocate (array) array => array_temp else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! ! -- normal return - return + return ! ! -- Error reporting 99 continue - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Could not increase array size' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Could not increase array size' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! @@ -272,11 +272,11 @@ subroutine extend_double(array, increment) call sim_message(ermsg) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) - + end subroutine extend_double subroutine extend_integer(array, increment) @@ -297,23 +297,23 @@ subroutine extend_integer(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (associated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize), stat=istat, errmsg=ermsg) + allocate (array_temp(newsize), stat=istat, errmsg=ermsg) if (istat /= 0) goto 99 - do i=1,isize + do i = 1, isize array_temp(i) = array(i) - enddo - deallocate(array) + end do + deallocate (array) array => array_temp else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! ! -- normal return return @@ -321,8 +321,8 @@ subroutine extend_integer(array, increment) ! -- Error reporting 99 continue - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Could not increase array size' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Could not increase array size' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! @@ -331,11 +331,11 @@ subroutine extend_integer(array, increment) call sim_message(ermsg) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) - + end subroutine extend_integer function ifind_character(array, str) @@ -350,12 +350,12 @@ function ifind_character(array, str) ! -- local integer(I4B) :: i ifind_character = -1 - findloop: do i=1,size(array) - if(array(i) == str) then + findloop: do i = 1, size(array) + if (array(i) == str) then ifind_character = i exit findloop - endif - enddo findloop + end if + end do findloop return end function ifind_character @@ -372,11 +372,11 @@ function ifind_integer(iarray, ival) integer(I4B) :: i ifind_integer = -1 findloop: do i = 1, size(iarray) - if(iarray(i) == ival) then + if (iarray(i) == ival) then ifind_integer = i exit findloop - endif - enddo findloop + end if + end do findloop return end function ifind_integer @@ -385,7 +385,7 @@ subroutine remove_character(array, ipos) implicit none ! -- dummy character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), intent(in) :: ipos + integer(I4B), intent(in) :: ipos ! -- local character(len=LINELENGTH) :: line character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp @@ -397,38 +397,38 @@ subroutine remove_character(array, ipos) lenc = len(array) if (lenc > MAXCHARLEN) then - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Need to increase MAXCHARLEN' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Need to increase MAXCHARLEN' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) - endif + end if ! ! -- calculate sizes isize = size(array) newsize = isize - 1 ! ! -- copy array to array_temp - allocate(array_temp(isize)) + allocate (array_temp(isize)) do i = 1, isize array_temp(i) = array(i) - enddo + end do ! - deallocate(array) - allocate(array(newsize)) + deallocate (array) + allocate (array(newsize)) inew = 1 do i = 1, isize - if(i /= ipos) then + if (i /= ipos) then array(inew) = array_temp(i) inew = inew + 1 - endif - enddo - deallocate(array_temp) + end if + end do + deallocate (array_temp) ! return end subroutine remove_character diff --git a/src/Utilities/ArrayReaders.f90 b/src/Utilities/ArrayReaders.f90 index 17125833ea5..973e4d5087e 100644 --- a/src/Utilities/ArrayReaders.f90 +++ b/src/Utilities/ArrayReaders.f90 @@ -1,27 +1,27 @@ module ArrayReadersModule - - use ConstantsModule, only: DONE, LINELENGTH, LENBIGLINE, LENBOUNDNAME, & - NAMEDBOUNDFLAG, LINELENGTH, DZERO, MAXCHARLEN, & - DZERO + + use ConstantsModule, only: DONE, LINELENGTH, LENBIGLINE, LENBOUNDNAME, & + NAMEDBOUNDFLAG, LINELENGTH, DZERO, MAXCHARLEN, & + DZERO use InputOutputModule, only: openfile, u8rdcom, urword, ucolno, ulaprw, & BuildFixedFormat, BuildFloatFormat, & BuildIntFormat - use KindModule, only: DP, I4B - use OpenSpecModule, only: ACCESS, FORM - use SimModule, only: store_error, store_error_unit + use KindModule, only: DP, I4B + use OpenSpecModule, only: ACCESS, FORM + use SimModule, only: store_error, store_error_unit implicit none private public :: ReadArray - + interface ReadArray module procedure read_array_int1d, read_array_int2d, read_array_int3d, & - read_array_dbl1d, read_array_dbl2d, read_array_dbl3d, & - read_array_dbl1d_layered, read_array_int1d_layered, & - read_array_dbl3d_all, read_array_int3d_all + read_array_dbl1d, read_array_dbl2d, read_array_dbl3d, & + read_array_dbl1d_layered, read_array_int1d_layered, & + read_array_dbl3d_all, read_array_int3d_all end interface ReadArray - + ! Integer readers ! read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) ! read_array_int1d_layered(iu, iarr, aname, ndim, ncol, nrow, nlay, nval, iout, k1, k2) @@ -35,19 +35,19 @@ module ArrayReadersModule ! read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, k1, k2) ! read_array_dbl3d_all(iu, darr, aname, ndim, nvals, iout) - + contains ! -- Procedures that are part of ReadArray interface (integer data) subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj integer(I4B), dimension(jj), intent(inout) :: iarr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: iclose, iconst, iprn, j, locat, ncpl, ndig integer(I4B) :: nval, nvalt @@ -57,8 +57,8 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',i0, ' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',i0) +2 format(/, 1x, a, ' = ', i0, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', i0) ! ! -- Read array control record. call read_control_int(iu, iout, aname, locat, iconst, iclose, iprn) @@ -66,60 +66,61 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do j=1,jj + do j = 1, jj iarr(j) = iconst - enddo + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), iconst, k + write (iout, 2) trim(aname), iconst, k else - write(iout,3) trim(aname), iconst - endif - endif + write (iout, 3) trim(aname), iconst + end if + end if elseif (locat > 0) then ! -- Read data as text - read(locat,*,iostat=istat,iomsg=ermsgr) (iarr(j),j=1,jj) + read (locat, *, iostat=istat, iomsg=ermsgr) (iarr(j), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj + end if + do j = 1, jj iarr(j) = iarr(j) * iconst - enddo + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat nvalt = 0 do call read_binary_header(locat, iout, aname, nval) - read(locat,iostat=istat,iomsg=ermsgr) (iarr(j), j=nvalt+1, nvalt+nval) + read (locat, iostat=istat, iomsg=ermsgr) & + (iarr(j), j=nvalt + 1, nvalt + nval) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if nvalt = nvalt + nval if (nvalt == size(iarr)) exit - enddo + end do ! ! -- multiply array by constant - do j=1,jj + do j = 1, jj iarr(j) = iarr(j) * iconst - enddo + end do ! ! -- close the file if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -127,19 +128,19 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) call build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_int(iarr, aname, iout, jj, 1, k, prfmt, ncpl, ndig, & prowcolnum) - endif + end if ! return end subroutine read_array_int1d subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj, ii - integer(I4B), dimension(jj,ii), intent(inout) :: iarr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj, ii + integer(I4B), dimension(jj, ii), intent(inout) :: iarr + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: i, iclose, iconst, iprn, j, locat, ncpl, ndig integer(I4B) :: nval @@ -149,8 +150,8 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',i0, ' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',i0) +2 format(/, 1x, a, ' = ', i0, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', i0) ! ! -- Read array control record. call read_control_int(iu, iout, aname, locat, iconst, iclose, iprn) @@ -158,57 +159,57 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do i=1,ii - do j=1,jj - iarr(j,i) = iconst - enddo - enddo + do i = 1, ii + do j = 1, jj + iarr(j, i) = iconst + end do + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), iconst, k + write (iout, 2) trim(aname), iconst, k else - write(iout,3) trim(aname), iconst - endif - endif + write (iout, 3) trim(aname), iconst + end if + end if elseif (locat > 0) then ! -- Read data as text - do i=1,ii - read(locat,*,iostat=istat,iomsg=ermsgr) (iarr(j,i),j=1,jj) + do i = 1, ii + read (locat, *, iostat=istat, iomsg=ermsgr) (iarr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj - iarr(j,i) = iarr(j,i) * iconst - enddo - enddo + end if + do j = 1, jj + iarr(j, i) = iarr(j, i) * iconst + end do + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat call read_binary_header(locat, iout, aname, nval) - do i=1,ii - read(locat,iostat=istat,iomsg=ermsgr) (iarr(j,i),j=1,jj) + do i = 1, ii + read (locat, iostat=istat, iomsg=ermsgr) (iarr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj - iarr(j,i) = iarr(j,i) * iconst - enddo - enddo + end if + do j = 1, jj + iarr(j, i) = iarr(j, i) * iconst + end do + end do if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -216,11 +217,11 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) call build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_int(iarr, aname, iout, jj, ii, k, prfmt, ncpl, & ndig, prowcolnum) - endif + end if ! return end subroutine read_array_int2d - + subroutine read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, & k1, k2) ! ****************************************************************************** @@ -237,7 +238,7 @@ subroutine read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, & integer(I4B), intent(in) :: nrow integer(I4B), intent(in) :: nlay integer(I4B), intent(in) :: k1, k2 - integer(I4B), dimension(ncol,nrow,nlay), intent(inout) :: iarr + integer(I4B), dimension(ncol, nrow, nlay), intent(inout) :: iarr character(len=*), intent(in) :: aname ! -- local integer(I4B) :: k, kk @@ -247,12 +248,12 @@ subroutine read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, & kk = 1 else kk = k - endif - call read_array_int2d(iu, iarr(:,:,kk), aname, ndim, ncol, nrow, iout, k) - enddo + end if + call read_array_int2d(iu, iarr(:, :, kk), aname, ndim, ncol, nrow, iout, k) + end do return end subroutine read_array_int3d - + subroutine read_array_int3d_all(iu, iarr, aname, ndim, nvals, iout) ! ****************************************************************************** ! Read three-dimensional integer array, all at once. @@ -264,7 +265,7 @@ subroutine read_array_int3d_all(iu, iarr, aname, ndim, nvals, iout) integer(I4B), intent(in) :: iout integer(I4B), intent(in) :: ndim integer(I4B), intent(in) :: nvals - integer(I4B), dimension(nvals,1,1), intent(inout) :: iarr + integer(I4B), dimension(nvals, 1, 1), intent(inout) :: iarr character(len=*), intent(in) :: aname ! -- local ! ------------------------------------------------------------------------------ @@ -277,29 +278,29 @@ end subroutine read_array_int3d_all subroutine read_array_int1d_layered(iu, iarr, aname, ndim, ncol, nrow, & nlay, nval, iout, k1, k2) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: ncol, nrow, nlay, nval + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: ncol, nrow, nlay, nval integer(I4B), dimension(nval), intent(inout) :: iarr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k1, k2 + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k1, k2 ! -- local ! call read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, k1, k2) ! return end subroutine read_array_int1d_layered - + ! -- Procedures that are part of ReadArray interface (floating-point data) - + subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj real(DP), dimension(jj), intent(inout) :: darr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: j, iclose, iprn, locat, ncpl, ndig real(DP) :: cnstnt @@ -310,8 +311,8 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',g14.7,' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',g14.7) +2 format(/, 1x, a, ' = ', g14.7, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', g14.7) ! ! -- Read array control record. call read_control_dbl(iu, iout, aname, locat, cnstnt, iclose, iprn) @@ -319,60 +320,61 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do j=1,jj + do j = 1, jj darr(j) = cnstnt - enddo + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), cnstnt, k + write (iout, 2) trim(aname), cnstnt, k else - write(iout,3) trim(aname), cnstnt - endif - endif + write (iout, 3) trim(aname), cnstnt + end if + end if elseif (locat > 0) then ! -- Read data as text - read(locat,*,iostat=istat,iomsg=ermsgr) (darr(j),j=1,jj) + read (locat, *, iostat=istat, iomsg=ermsgr) (darr(j), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj + end if + do j = 1, jj darr(j) = darr(j) * cnstnt - enddo + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat nvalt = 0 do call read_binary_header(locat, iout, aname, nval) - read(locat,iostat=istat,iomsg=ermsgr) (darr(j), j=nvalt+1, nvalt+nval) + read (locat, iostat=istat, iomsg=ermsgr) & + (darr(j), j=nvalt + 1, nvalt + nval) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if nvalt = nvalt + nval if (nvalt == size(darr)) exit - enddo + end do ! ! -- multiply entire array by constant do j = 1, jj darr(j) = darr(j) * cnstnt - enddo + end do ! ! -- close the file if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -380,19 +382,19 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) call build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_dbl(darr, aname, iout, jj, 1, k, prfmt, ncpl, ndig, & prowcolnum) - endif + end if ! return end subroutine read_array_dbl1d subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj, ii - real(DP), dimension(jj,ii), intent(inout) :: darr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj, ii + real(DP), dimension(jj, ii), intent(inout) :: darr + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: i, iclose, iprn, j, locat, ncpl, ndig integer(I4B) :: nval @@ -403,8 +405,8 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',g14.7, ' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',g14.7) +2 format(/, 1x, a, ' = ', g14.7, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', g14.7) ! ! -- Read array control record. call read_control_dbl(iu, iout, aname, locat, cnstnt, iclose, iprn) @@ -412,57 +414,57 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do i=1,ii - do j=1,jj - darr(j,i) = cnstnt - enddo - enddo + do i = 1, ii + do j = 1, jj + darr(j, i) = cnstnt + end do + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), cnstnt, k + write (iout, 2) trim(aname), cnstnt, k else - write(iout,3) trim(aname), cnstnt - endif - endif + write (iout, 3) trim(aname), cnstnt + end if + end if elseif (locat > 0) then ! -- Read data as text - do i=1,ii - read(locat,*,iostat=istat,iomsg=ermsgr) (darr(j,i),j=1,jj) + do i = 1, ii + read (locat, *, iostat=istat, iomsg=ermsgr) (darr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj - darr(j,i) = darr(j,i) * cnstnt - enddo - enddo + end if + do j = 1, jj + darr(j, i) = darr(j, i) * cnstnt + end do + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat call read_binary_header(locat, iout, aname, nval) do i = 1, ii - read(locat,iostat=istat,iomsg=ermsgr) (darr(j,i), j = 1, jj) + read (locat, iostat=istat, iomsg=ermsgr) (darr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if do j = 1, jj - darr(j,i) = darr(j,i) * cnstnt - enddo - enddo + darr(j, i) = darr(j, i) * cnstnt + end do + end do if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -470,11 +472,11 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) call build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, ncpl, & ndig, prowcolnum) - endif + end if ! return end subroutine read_array_dbl2d - + subroutine read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, & k1, k2) ! ****************************************************************************** @@ -491,24 +493,24 @@ subroutine read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, & integer(I4B), intent(in) :: nrow integer(I4B), intent(in) :: nlay integer(I4B), intent(in) :: k1, k2 - real(DP), dimension(ncol,nrow,nlay), intent(inout) :: darr + real(DP), dimension(ncol, nrow, nlay), intent(inout) :: darr character(len=*), intent(in) :: aname ! -- local integer(I4B) :: k, kk ! ------------------------------------------------------------------------------ ! - do k=k1,k2 + do k = k1, k2 if (k <= 0) then kk = 1 else kk = k - endif - call read_array_dbl2d(iu, darr(:,:,kk), aname, ndim, ncol, nrow, iout, k) - enddo + end if + call read_array_dbl2d(iu, darr(:, :, kk), aname, ndim, ncol, nrow, iout, k) + end do ! return end subroutine read_array_dbl3d - + subroutine read_array_dbl3d_all(iu, darr, aname, ndim, nvals, iout) ! ****************************************************************************** ! Read three-dimensional real array, consisting of one or more 2d arrays with @@ -521,7 +523,7 @@ subroutine read_array_dbl3d_all(iu, darr, aname, ndim, nvals, iout) integer(I4B), intent(in) :: iout integer(I4B), intent(in) :: ndim integer(I4B), intent(in) :: nvals - real(DP), dimension(nvals,1,1), intent(inout) :: darr + real(DP), dimension(nvals, 1, 1), intent(inout) :: darr character(len=*), intent(in) :: aname ! -- local ! ------------------------------------------------------------------------------ @@ -534,12 +536,12 @@ end subroutine read_array_dbl3d_all subroutine read_array_dbl1d_layered(iu, darr, aname, ndim, ncol, nrow, & nlay, nval, iout, k1, k2) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: ncol, nrow, nlay, nval + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: ncol, nrow, nlay, nval real(DP), dimension(nval), intent(inout) :: darr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k1, k2 + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k1, k2 ! -- local ! call read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, k1, k2) @@ -548,23 +550,23 @@ subroutine read_array_dbl1d_layered(iu, darr, aname, ndim, ncol, nrow, & end subroutine read_array_dbl1d_layered ! -- Utility procedures - + subroutine read_control_int(iu, iout, aname, locat, iconst, & iclose, iprn) ! Read an array-control record for an integer array. ! Open an input file if needed. ! If CONSTANT is specified in input, locat is returned as 0. - ! If (BINARY) is specified, locat is returned as the negative of + ! If (BINARY) is specified, locat is returned as the negative of ! the unit number opened for binary read. ! If OPEN/CLOSE is specified, iclose is returned as 1, otherwise 0. ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: aname - integer(I4B), intent(out) :: locat - integer(I4B), intent(out) :: iconst - integer(I4B), intent(out) :: iclose - integer(I4B), intent(out) :: iprn + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: aname + integer(I4B), intent(out) :: locat + integer(I4B), intent(out) :: iconst + integer(I4B), intent(out) :: iclose + integer(I4B), intent(out) :: iprn ! -- local integer(I4B) :: icol, icol1, istart, istop, n real(DP) :: r @@ -574,23 +576,23 @@ subroutine read_control_int(iu, iout, aname, locat, iconst, & call read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) if (locat == 0) then ! CONSTANT was found -- read value and return - call urword(line,icol,istart,istop,2,iconst,r,iout,iu) + call urword(line, icol, istart, istop, 2, iconst, r, iout, iu) iprn = -1 return - endif + end if icol1 = icol iconst = 1 ! ! -- Read FACTOR option from array control record. call urword(line, icol, istart, istop, 1, n, r, iout, iu) if (line(istart:istop) == 'FACTOR') then - call urword(line,icol,istart,istop,2,iconst,r,iout,iu) + call urword(line, icol, istart, istop, 2, iconst, r, iout, iu) if (iconst == 0) iconst = 1 else icol = icol1 - endif + end if ! - ! -- Read (BINARY) and IPRN options from array control record, + ! -- Read (BINARY) and IPRN options from array control record, ! and open an OPEN/CLOSE file if specified. call read_control_2(iu, iout, fname, line, icol, locat, iclose, iprn) ! @@ -602,17 +604,17 @@ subroutine read_control_dbl(iu, iout, aname, locat, cnstnt, & ! Read an array-control record for a double-precision array. ! Open an input file if needed. ! If CONSTANT is specified in input, locat is returned as 0. - ! If (BINARY) is specified, locat is returned as the negative of + ! If (BINARY) is specified, locat is returned as the negative of ! the unit number opened for binary read. ! If OPEN/CLOSE is specified, iclose is returned as 1, otherwise 0. ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: aname - integer(I4B), intent(out) :: locat - real(DP), intent(out) :: cnstnt - integer(I4B), intent(out) :: iclose - integer(I4B), intent(out) :: iprn + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: aname + integer(I4B), intent(out) :: locat + real(DP), intent(out) :: cnstnt + integer(I4B), intent(out) :: iclose + integer(I4B), intent(out) :: iprn ! ! -- local integer(I4B) :: icol, icol1, istart, istop, n @@ -623,41 +625,41 @@ subroutine read_control_dbl(iu, iout, aname, locat, cnstnt, & call read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) if (locat == 0) then ! CONSTANT was found -- read value and return - call urword(line,icol,istart,istop,3,n,cnstnt,iout,iu) + call urword(line, icol, istart, istop, 3, n, cnstnt, iout, iu) iprn = -1 return - endif + end if icol1 = icol cnstnt = DONE ! ! -- Read FACTOR option from array control record. call urword(line, icol, istart, istop, 1, n, r, iout, iu) if (line(istart:istop) == 'FACTOR') then - call urword(line,icol,istart,istop,3,n,cnstnt,iout,iu) + call urword(line, icol, istart, istop, 3, n, cnstnt, iout, iu) if (cnstnt == DZERO) cnstnt = DONE else icol = icol1 - endif + end if ! - ! -- Read (BINARY) and IPRN options from array control record, + ! -- Read (BINARY) and IPRN options from array control record, ! and open an OPEN/CLOSE file if specified. call read_control_2(iu, iout, fname, line, icol, locat, iclose, iprn) ! return end subroutine read_control_dbl - + subroutine read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) ! -- Read CONSTANT, INTERNAL, or OPEN/CLOSE from array control record. ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: aname - integer(I4B), intent(out) :: locat - integer(I4B), intent(out) :: iclose + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: aname + integer(I4B), intent(out) :: locat + integer(I4B), intent(out) :: iclose character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: icol + integer(I4B), intent(inout) :: icol character(len=*), intent(inout) :: fname - + ! -- local integer(I4B) :: istart, istop, n integer(I4B) :: ierr @@ -665,43 +667,43 @@ subroutine read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) character(len=MAXCHARLEN) :: ermsg ! ! -- Read array control record. - call u8rdcom(iu,iout,line,ierr) + call u8rdcom(iu, iout, line, ierr) ! iclose = 0 icol = 1 ! -- Read first token of array control record. - call urword(line,icol,istart,istop,1,n,r,iout,iu) - if (line(istart:istop).eq.'CONSTANT') then + call urword(line, icol, istart, istop, 1, n, r, iout, iu) + if (line(istart:istop) .eq. 'CONSTANT') then locat = 0 - elseif (line(istart:istop).eq.'INTERNAL') then + elseif (line(istart:istop) .eq. 'INTERNAL') then locat = iu - elseif (line(istart:istop).eq.'OPEN/CLOSE') then - call urword(line,icol,istart,istop,0,n,r,iout,iu) + elseif (line(istart:istop) .eq. 'OPEN/CLOSE') then + call urword(line, icol, istart, istop, 0, n, r, iout, iu) fname = line(istart:istop) locat = -1 iclose = 1 else - write(ermsg, *) 'ERROR READING CONTROL RECORD FOR ' // & - trim(adjustl(aname)) + write (ermsg, *) 'ERROR READING CONTROL RECORD FOR '// & + trim(adjustl(aname)) call store_error(ermsg) call store_error(trim(adjustl(line))) - write(ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.' + write (ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.' call store_error(ermsg) call store_error_unit(iu) - endif + end if ! return end subroutine read_control_1 - + subroutine read_control_2(iu, iout, fname, line, icol, & locat, iclose, iprn) - ! -- Read (BINARY) and IPRN options from array control record, + ! -- Read (BINARY) and IPRN options from array control record, ! and open an OPEN/CLOSE file if specified. ! -- dummy - integer(I4B), intent(in) :: iu, iout, iclose - character(len=*), intent(in) :: fname + integer(I4B), intent(in) :: iu, iout, iclose + character(len=*), intent(in) :: fname character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: icol, iprn, locat + integer(I4B), intent(inout) :: icol, iprn, locat ! -- local integer(I4B) :: i, n, istart, istop, lenkey real(DP) :: r @@ -709,38 +711,38 @@ subroutine read_control_2(iu, iout, fname, line, icol, & character(len=LENBIGLINE) :: ermsg logical :: binary ! - iprn = -1 ! Printing is turned off by default + iprn = -1 ! Printing is turned off by default binary = .false. ! - if (locat.ne.0) then + if (locat .ne. 0) then ! -- CONSTANT has not been specified; array data will be read. ! -- Read at most two options. - do i=1,2 - call urword(line,icol,istart,istop,1,n,r,iout,iu) + do i = 1, 2 + call urword(line, icol, istart, istop, 1, n, r, iout, iu) keyword = line(istart:istop) lenkey = len_trim(keyword) select case (keyword) case ('(BINARY)') if (iclose == 0) then - ermsg = '"(BINARY)" option for array input is valid only if' // & + ermsg = '"(BINARY)" option for array input is valid only if'// & ' OPEN/CLOSE is also specified.' call store_error(ermsg) call store_error_unit(iu) - endif + end if binary = .true. case ('IPRN') ! -- Read IPRN value - call urword(line,icol,istart,istop,2,iprn,r,iout,iu) + call urword(line, icol, istart, istop, 2, iprn, r, iout, iu) exit case ('') exit case default ermsg = 'Invalid option found in array-control record: "' & - // trim(keyword) // '"' + //trim(keyword)//'"' call store_error(ermsg) call store_error_unit(iu) end select - enddo + end do ! if (iclose == 0) then ! -- Array data will be read from current input file. @@ -753,9 +755,9 @@ subroutine read_control_2(iu, iout, fname, line, icol, & locat = -locat else call openfile(locat, iout, fname, 'OPEN/CLOSE') - endif - endif - endif + end if + end if + end if ! return end subroutine read_control_2 @@ -763,17 +765,17 @@ end subroutine read_control_2 subroutine build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) ! -- Build a print format for integers based on IPRN. ! -- dummy - integer(I4B), intent(inout) :: iprn + integer(I4B), intent(inout) :: iprn character(len=*), intent(out) :: prfmt - logical, intent(in) :: prowcolnum - integer(I4B), intent(out) :: ncpl, ndig + logical, intent(in) :: prowcolnum + integer(I4B), intent(out) :: ncpl, ndig ! -- local integer(I4B) :: nwidp ! if (iprn < 0) then prfmt = '' return - endif + end if ! if (iprn > 9) iprn = 0 ! @@ -815,14 +817,14 @@ subroutine build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) ! return end subroutine build_format_int - + subroutine build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) ! -- Build a print format for reals based on IPRN. ! -- dummy - integer(I4B), intent(inout) :: iprn + integer(I4B), intent(inout) :: iprn character(len=*), intent(out) :: prfmt - logical, intent(in) :: prowcolnum - integer(I4B), intent(out) :: ncpl, ndig + logical, intent(in) :: prowcolnum + integer(I4B), intent(out) :: ncpl, ndig ! -- local integer(I4B) :: nwidp character(len=1) :: editdesc @@ -830,7 +832,7 @@ subroutine build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) if (iprn < 0) then prfmt = '' return - endif + end if ! if (iprn > 21) iprn = 0 ! @@ -951,7 +953,7 @@ subroutine build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) call BuildFixedFormat(ncpl, nwidp, ndig, prfmt, prowcolnum) else call BuildFloatFormat(ncpl, nwidp, ndig, editdesc, prfmt, prowcolnum) - endif + end if ! ndig = nwidp + 1 ! @@ -961,28 +963,28 @@ end subroutine build_format_dbl subroutine print_array_int(iarr, aname, iout, jj, ii, k, prfmt, & ncpl, ndig, prowcolnum) ! -- dummy - integer(I4B), intent(in) :: iout, jj, ii, k - integer(I4B), intent(in) :: ncpl ! # values to print per line - integer(I4B), intent(in) :: ndig ! # characters in each field - integer(I4B), dimension(jj,ii), intent(in) :: iarr ! Integer array to be printed - character(len=*), intent(in) :: aname ! Array name - character(len=*), intent(in) :: prfmt ! Print format, no row # - logical, intent(in) :: prowcolnum ! Print row & column numbers + integer(I4B), intent(in) :: iout, jj, ii, k + integer(I4B), intent(in) :: ncpl ! # values to print per line + integer(I4B), intent(in) :: ndig ! # characters in each field + integer(I4B), dimension(jj, ii), intent(in) :: iarr ! Integer array to be printed + character(len=*), intent(in) :: aname ! Array name + character(len=*), intent(in) :: prfmt ! Print format, no row # + logical, intent(in) :: prowcolnum ! Print row & column numbers ! -- local integer(I4B) :: i, j character(len=MAXCHARLEN) :: ermsg ! -- formats - 2 format(/,1x,a,1x,'FOR LAYER ',i0) - 3 format(/,1x,a) +2 format(/, 1x, a, 1x, 'FOR LAYER ', i0) +3 format(/, 1x, a) ! if (iout <= 0) return ! ! -- Write name of array if (k > 0) then - write(iout,2)trim(aname),k + write (iout, 2) trim(aname), k else - write(iout,3)trim(aname) - endif + write (iout, 3) trim(aname) + end if ! ! -- Write array if (prowcolnum) then @@ -990,19 +992,19 @@ subroutine print_array_int(iarr, aname, iout, jj, ii, k, prfmt, & call ucolno(1, jj, 4, ncpl, ndig, iout) ! ! -- Write array values, including row numbers - do i=1,ii - write(iout, prfmt) i, (iarr(j,i),j=1,jj) - enddo + do i = 1, ii + write (iout, prfmt) i, (iarr(j, i), j=1, jj) + end do else if (ii > 1) then - ermsg = 'Program error printing array ' // trim(aname) // & + ermsg = 'Program error printing array '//trim(aname)// & ': ii > 1 when prowcolnum is false.' call store_error(ermsg, terminate=.TRUE.) - endif + end if ! ! -- Write array values, without row numbers - write(iout, prfmt) (iarr(j,1),j=1,jj) - endif + write (iout, prfmt) (iarr(j, 1), j=1, jj) + end if ! return end subroutine print_array_int @@ -1010,28 +1012,28 @@ end subroutine print_array_int subroutine print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, & ncpl, ndig, prowcolnum) ! -- dummy - integer(I4B), intent(in) :: iout, jj, ii, k - integer(I4B), intent(in) :: ncpl ! # values to print per line - integer(I4B), intent(in) :: ndig ! # characters in each field - real(DP), dimension(jj,ii), intent(in) :: darr ! Real array to be printed - character(len=*), intent(in) :: aname ! Array name - character(len=*), intent(in) :: prfmt ! Print format, no row # - logical, intent(in) :: prowcolnum ! Print row & column numbers + integer(I4B), intent(in) :: iout, jj, ii, k + integer(I4B), intent(in) :: ncpl ! # values to print per line + integer(I4B), intent(in) :: ndig ! # characters in each field + real(DP), dimension(jj, ii), intent(in) :: darr ! Real array to be printed + character(len=*), intent(in) :: aname ! Array name + character(len=*), intent(in) :: prfmt ! Print format, no row # + logical, intent(in) :: prowcolnum ! Print row & column numbers ! -- local integer(I4B) :: i, j character(len=MAXCHARLEN) :: ermsg ! -- formats - 2 format(/,1x,a,1x,'FOR LAYER ',i0) - 3 format(/,1x,a) +2 format(/, 1x, a, 1x, 'FOR LAYER ', i0) +3 format(/, 1x, a) ! if (iout <= 0) return ! ! -- Write name of array if (k > 0) then - write(iout,2)trim(aname),k + write (iout, 2) trim(aname), k else - write(iout,3)trim(aname) - endif + write (iout, 3) trim(aname) + end if ! ! -- Write array if (prowcolnum) then @@ -1039,19 +1041,19 @@ subroutine print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, & call ucolno(1, jj, 4, ncpl, ndig, iout) ! ! -- Write array values, including row numbers - do i=1,ii - write(iout, prfmt) i, (darr(j,i),j=1,jj) - enddo + do i = 1, ii + write (iout, prfmt) i, (darr(j, i), j=1, jj) + end do else if (ii > 1) then - ermsg = 'Program error printing array ' // trim(aname) // & + ermsg = 'Program error printing array '//trim(aname)// & ': ii > 1 when prowcolnum is false.' call store_error(ermsg, terminate=.TRUE.) - endif + end if ! ! -- Write array values, without row numbers - write(iout, prfmt) (darr(j,1),j=1,jj) - endif + write (iout, prfmt) (darr(j, 1), j=1, jj) + end if ! return end subroutine print_array_dbl @@ -1076,21 +1078,21 @@ subroutine read_binary_header(locat, iout, arrname, nval) &/,4X,'MSIZE 1: ',I0,' MSIZE 2: ',I0,' MSIZE 3: ',I0)" ! ! -- Read the header line from the binary file - read(locat, iostat=istat, iomsg=ermsgr) kstp, kper, pertim, totim, text, & + read (locat, iostat=istat, iomsg=ermsgr) kstp, kper, pertim, totim, text, & m1, m2, m3 ! ! -- Check for errors if (istat /= 0) then - ermsg = 'Error reading data for array: ' // adjustl(trim(arrname)) + ermsg = 'Error reading data for array: '//adjustl(trim(arrname)) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if ! ! -- Write message about the binary header if (iout > 0) then - write(iout, fmthdr) kstp, kper, pertim, totim, text, m1, m2, m3 - endif + write (iout, fmthdr) kstp, kper, pertim, totim, text, m1, m2, m3 + end if ! ! -- Assign the number of values that follow the header nval = m1 * m2 @@ -1098,5 +1100,5 @@ subroutine read_binary_header(locat, iout, arrname, nval) ! -- return return end subroutine read_binary_header - + end module ArrayReadersModule diff --git a/src/Utilities/BlockParser.f90 b/src/Utilities/BlockParser.f90 index eb29c678af0..2cc5159db58 100644 --- a/src/Utilities/BlockParser.f90 +++ b/src/Utilities/BlockParser.f90 @@ -5,31 +5,31 @@ !! !< module BlockParserModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENHUGELINE, LINELENGTH, MAXCHARLEN - use VersionModule, only: IDEVELOPMODE - use InputOutputModule, only: uget_block, uget_any_block, uterminate_block, & - u9rdcom, urword, upcase - use SimModule, only: store_error, store_error_unit + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENHUGELINE, LINELENGTH, MAXCHARLEN + use VersionModule, only: IDEVELOPMODE + use InputOutputModule, only: uget_block, uget_any_block, uterminate_block, & + u9rdcom, urword, upcase + use SimModule, only: store_error, store_error_unit use SimVariablesModule, only: errmsg - + implicit none - + private public :: BlockParserType - + type :: BlockParserType - integer(I4B), public :: iuactive !< flag indicating if a file unit is active, variable is not used internally - integer(I4B), private :: inunit !< file unit number - integer(I4B), private :: iuext !< external file unit number - integer(I4B), private :: iout !< listing file unit number - integer(I4B), private :: linesRead !< number of lines read - integer(I4B), private :: lloc !< line location counter - character(len=LINELENGTH), private :: blockName !< block name - character(len=LINELENGTH), private :: blockNameFound !< block name found - character(len=LENHUGELINE), private :: laststring !< last string read - character(len=:), allocatable, private :: line !< current line + integer(I4B), public :: iuactive !< flag indicating if a file unit is active, variable is not used internally + integer(I4B), private :: inunit !< file unit number + integer(I4B), private :: iuext !< external file unit number + integer(I4B), private :: iout !< listing file unit number + integer(I4B), private :: linesRead !< number of lines read + integer(I4B), private :: lloc !< line location counter + character(len=LINELENGTH), private :: blockName !< block name + character(len=LINELENGTH), private :: blockNameFound !< block name found + character(len=LENHUGELINE), private :: laststring !< last string read + character(len=:), allocatable, private :: line !< current line contains procedure, public :: Initialize procedure, public :: Clear @@ -49,7 +49,7 @@ module BlockParserModule procedure, public :: DevOpt procedure, private :: ReadScalarError end type BlockParserType - + contains !> @ brief Initialize the block parser @@ -59,9 +59,9 @@ module BlockParserModule !< subroutine Initialize(this, inunit, iout) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - integer(I4B), intent(in) :: inunit !< input file unit number - integer(I4B), intent(in) :: iout !< listing file unit number + class(BlockParserType), intent(inout) :: this !< BlockParserType object + integer(I4B), intent(in) :: inunit !< input file unit number + integer(I4B), intent(in) :: iout !< listing file unit number ! ! -- initialize values this%inunit = inunit @@ -74,7 +74,7 @@ subroutine Initialize(this, inunit, iout) ! -- return return end subroutine Initialize - + !> @ brief Close the block parser !! !! Method to clear the block parser, which closes file(s) and clears member @@ -83,24 +83,24 @@ end subroutine Initialize !< subroutine Clear(this) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables logical :: lop ! ! Close any connected files if (this%inunit > 0) then - inquire(unit=this%inunit, opened=lop) + inquire (unit=this%inunit, opened=lop) if (lop) then - close(this%inunit) - endif - endif + close (this%inunit) + end if + end if ! if (this%iuext /= this%inunit .and. this%iuext > 0) then - inquire(unit=this%iuext, opened=lop) + inquire (unit=this%iuext, opened=lop) if (lop) then - close(this%iuext) - endif - endif + close (this%iuext) + end if + end if ! ! Clear all member variables this%inunit = 0 @@ -111,12 +111,12 @@ subroutine Clear(this) this%linesRead = 0 this%blockName = '' this%line = '' - deallocate(this%line) + deallocate (this%line) ! ! -- return return end subroutine Clear - + !> @ brief Get block !! !! Method to get the block from a file. The file is read until the blockname @@ -126,13 +126,13 @@ end subroutine Clear subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & blockRequired, blockNameFound) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(in) :: blockName !< block name to search for - logical, intent(out) :: isFound !< boolean indicating if the block name was found - integer(I4B), intent(out) :: ierr !< return error code, 0 indicates block was found - logical, intent(in), optional :: supportOpenClose !< boolean indicating if the block supports open/close, default false - logical, intent(in), optional :: blockRequired !< boolean indicating if the block is required, default true - character(len=*), intent(inout), optional :: blockNameFound !< optional return value of block name found + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(in) :: blockName !< block name to search for + logical, intent(out) :: isFound !< boolean indicating if the block name was found + integer(I4B), intent(out) :: ierr !< return error code, 0 indicates block was found + logical, intent(in), optional :: supportOpenClose !< boolean indicating if the block supports open/close, default false + logical, intent(in), optional :: blockRequired !< boolean indicating if the block is required, default true + character(len=*), intent(inout), optional :: blockNameFound !< optional return value of block name found ! -- local variables logical :: continueRead logical :: supportOpenCloseLocal @@ -143,13 +143,13 @@ subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & supportOpenCloseLocal = supportOpenClose else supportOpenCloseLocal = .false. - endif + end if ! if (present(blockRequired)) then blockRequiredLocal = blockRequired else blockRequiredLocal = .true. - endif + end if continueRead = blockRequiredLocal this%blockName = blockName this%blockNameFound = '' @@ -162,13 +162,13 @@ subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & ierr = 0 else ierr = 1 - endif + end if else call uget_block(this%inunit, this%iout, this%blockName, ierr, isFound, & this%lloc, this%line, this%iuext, continueRead, & supportOpenCloseLocal) if (isFound) this%blockNameFound = this%blockName - endif + end if this%iuactive = this%iuext this%linesRead = 0 ! @@ -183,8 +183,8 @@ end subroutine GetBlock !< subroutine GetNextLine(this, endOfBlock) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - logical, intent(out) :: endOfBlock !< boolean indicating if the end of the block was read + class(BlockParserType), intent(inout) :: this !< BlockParserType object + logical, intent(out) :: endOfBlock !< boolean indicating if the end of the block was read ! -- local variables integer(I4B) :: ierr integer(I4B) :: ival @@ -216,24 +216,24 @@ subroutine GetNextLine(this, endOfBlock) endOfBlock = .true. lineread = .true. elseif (key == '') then - ! End of file reached. - ! If this is an OPEN/CLOSE file, close the file and read the next + ! End of file reached. + ! If this is an OPEN/CLOSE file, close the file and read the next ! line from this%inunit. if (this%iuext /= this%inunit) then - close(this%iuext) + close (this%iuext) this%iuext = this%inunit this%iuactive = this%inunit else errmsg = 'Unexpected end of file reached.' call store_error(errmsg) call this%StoreErrorUnit() - endif + end if else this%lloc = 1 this%linesRead = this%linesRead + 1 lineread = .true. - endif - enddo loop1 + end if + end do loop1 ! ! -- return return @@ -246,9 +246,9 @@ end subroutine GetNextLine !< function GetInteger(this) result(i) ! -- return variable - integer(I4B) :: i !< integer variable + integer(I4B) :: i !< integer variable ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables integer(I4B) :: istart integer(I4B) :: istop @@ -261,12 +261,12 @@ function GetInteger(this) result(i) ! -- Make sure variable was read before end of line if (istart == istop .and. istop == len(this%line)) then call this%ReadScalarError('INTEGER') - endif + end if ! ! -- return return end function GetInteger - + !> @ brief Get the number of lines read !! !! Function to get the number of lines read from the current block. @@ -274,28 +274,28 @@ end function GetInteger !< function GetLinesRead(this) result(nlines) ! -- return variable - integer(I4B) :: nlines !< number of lines read + integer(I4B) :: nlines !< number of lines read ! -- dummy variable - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! ! -- number of lines read - nlines = this%linesRead + nlines = this%linesRead ! ! -- return return end function GetLinesRead - + !> @ brief Get a double precision real !! - !! Function to get adouble precision floating point number from + !! Function to get adouble precision floating point number from !! the current line. !! !< function GetDouble(this) result(r) ! -- return variable - real(DP) :: r !< double precision real variable + real(DP) :: r !< double precision real variable ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables integer(I4B) :: istart integer(I4B) :: istop @@ -308,12 +308,12 @@ function GetDouble(this) result(r) ! -- Make sure variable was read before end of line if (istart == istop .and. istop == len(this%line)) then call this%ReadScalarError('DOUBLE PRECISION') - endif + end if ! ! -- return return end function GetDouble - + !> @ brief Issue a read error !! !! Method to issue an unable to read error. @@ -321,20 +321,20 @@ end function GetDouble !< subroutine ReadScalarError(this, vartype) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(in) :: vartype !< string of variable type + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(in) :: vartype !< string of variable type ! -- local variables - character(len=MAXCHARLEN-100) :: linetemp + character(len=MAXCHARLEN - 100) :: linetemp ! ! -- use linetemp as line may be longer than MAXCHARLEN linetemp = this%line ! ! -- write the message - write(errmsg, '(3a)') 'Error in block ', trim(this%blockName), '.' - write(errmsg, '(4a)') & - trim(errmsg), ' Could not read variable of type ', trim(vartype), & - " from the following line: '" - write(errmsg, '(3a)') & + write (errmsg, '(3a)') 'Error in block ', trim(this%blockName), '.' + write (errmsg, '(4a)') & + trim(errmsg), ' Could not read variable of type ', trim(vartype), & + " from the following line: '" + write (errmsg, '(3a)') & trim(errmsg), trim(adjustl(this%line)), "'." call store_error(errmsg) call this%StoreErrorUnit() @@ -342,7 +342,7 @@ subroutine ReadScalarError(this, vartype) ! -- return return end subroutine ReadScalarError - + !> @ brief Get a string !! !! Method to get a string from the current line and optionally convert it @@ -351,8 +351,8 @@ end subroutine ReadScalarError !< subroutine GetString(this, string, convertToUpper) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(out) :: string !< string + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(out) :: string !< string logical, optional, intent(in) :: convertToUpper !< boolean indicating if the string should be converted to upper case, default false ! -- local variables integer(I4B) :: istart @@ -367,10 +367,10 @@ subroutine GetString(this, string, convertToUpper) ncode = 1 else ncode = 0 - endif + end if else ncode = 0 - endif + end if ! call urword(this%line, this%lloc, istart, istop, ncode, & ival, rval, this%iout, this%iuext) @@ -389,8 +389,8 @@ end subroutine GetString !< subroutine GetStringCaps(this, string) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(out) :: string !< upper case string + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(out) :: string !< upper case string ! ! -- call base GetString method with convertToUpper variable call this%GetString(string, convertToUpper=.true.) @@ -406,8 +406,8 @@ end subroutine GetStringCaps !< subroutine GetRemainingLine(this, line) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=:), allocatable, intent(out) :: line !< remainder of the line + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=:), allocatable, intent(out) :: line !< remainder of the line ! -- local variables integer(I4B) :: lastpos integer(I4B) :: newlinelen @@ -416,14 +416,14 @@ subroutine GetRemainingLine(this, line) lastpos = len_trim(this%line) newlinelen = lastpos - this%lloc + 2 newlinelen = max(newlinelen, 1) - allocate(character(len=newlinelen) :: line) - line(:) = this%line(this%lloc:lastpos) + allocate (character(len=newlinelen) :: line) + line(:) = this%line(this%lloc:lastpos) line(newlinelen:newlinelen) = ' ' ! ! -- return return end subroutine GetRemainingLine - + !> @ brief Ensure that the block is closed !! !! Method to ensure that the block is closed with an "end". @@ -431,18 +431,18 @@ end subroutine GetRemainingLine !< subroutine terminateblock(this) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables logical :: endofblock ! ! -- look for block termination call this%GetNextLine(endofblock) if (.not. endofblock) then - errmsg = "LOOKING FOR 'END " // trim(this%blockname) // & - "'. FOUND: " // "'" // trim(this%line) // "'." + errmsg = "LOOKING FOR 'END "//trim(this%blockname)// & + "'. FOUND: "//"'"//trim(this%line)//"'." call store_error(errmsg) call this%StoreErrorUnit() - endif + end if ! ! -- return return @@ -455,10 +455,10 @@ end subroutine terminateblock !< subroutine GetCellid(this, ndim, cellid, flag_string) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - integer(I4B), intent(in) :: ndim !< number of dimensions (1, 2, or 3) - character(len=*), intent(out) :: cellid !< cell =id - logical, optional, intent(in) :: flag_string !< boolean indicating id cellid is a string + class(BlockParserType), intent(inout) :: this !< BlockParserType object + integer(I4B), intent(in) :: ndim !< number of dimensions (1, 2, or 3) + character(len=*), intent(out) :: cellid !< cell =id + logical, optional, intent(in) :: flag_string !< boolean indicating id cellid is a string ! -- local variables integer(I4B) :: i integer(I4B) :: j @@ -477,24 +477,24 @@ subroutine GetCellid(this, ndim, cellid, flag_string) call urword(this%line, lloc, istart, istop, 0, ival, rval, this%iout, & this%iuext) firsttoken = this%line(istart:istop) - read(firsttoken,*,iostat=istat) ival + read (firsttoken, *, iostat=istat) ival if (istat > 0) then call upcase(firsttoken) cellid = firsttoken return - endif - endif + end if + end if ! cellid = '' - do i=1,ndim + do i = 1, ndim j = this%GetInteger() - write(cint,'(i0)') j + write (cint, '(i0)') j if (i == 1) then cellid = cint else - cellid = trim(cellid) // ' ' // cint - endif - enddo + cellid = trim(cellid)//' '//cint + end if + end do ! ! -- return return @@ -507,8 +507,8 @@ end subroutine GetCellid !< subroutine GetCurrentLine(this, line) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(out) :: line !< current line + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(out) :: line !< current line ! ! -- get the current line line = this%line @@ -525,8 +525,8 @@ end subroutine GetCurrentLine !< subroutine StoreErrorUnit(this, terminate) ! -- dummy variable - class(BlockParserType), intent(inout) :: this !< BlockParserType object - logical, intent(in), optional :: terminate !< boolean indicating if the simulation should be terminated + class(BlockParserType), intent(inout) :: this !< BlockParserType object + logical, intent(in), optional :: terminate !< boolean indicating if the simulation should be terminated ! -- loacl variables logical :: lterminate ! @@ -536,7 +536,7 @@ subroutine StoreErrorUnit(this, terminate) else lterminate = .TRUE. end if - ! + ! ! -- store error unit call store_error_unit(this%iuext, terminate=lterminate) ! @@ -551,9 +551,9 @@ end subroutine StoreErrorUnit !< function GetUnit(this) result(i) ! -- return variable - integer(I4B) :: i !< unit number for the block parser + integer(I4B) :: i !< unit number for the block parser ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! ! -- block parser unit number i = this%iuext @@ -564,7 +564,7 @@ end function GetUnit !> @ brief Development option !! - !! Method that will cause the program to terminate with an error if the + !! Method that will cause the program to terminate with an error if the !! IDEVELOPMODE flag is set to 1. This is used to allow develop options !! to be specified for development testing but not for the public release. !! For the public release, IDEVELOPMODE is set to zero. @@ -572,16 +572,16 @@ end function GetUnit !< subroutine DevOpt(this) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! ! -- If release mode (not develop mode), then option not available. ! Terminate with an error. if (IDEVELOPMODE == 0) then - errmsg = "Invalid keyword '" // trim(this%laststring) // & - "' detected in block '" // trim(this%blockname) // "'." + errmsg = "Invalid keyword '"//trim(this%laststring)// & + "' detected in block '"//trim(this%blockname)//"'." call store_error(errmsg) call this%StoreErrorUnit() - endif + end if ! ! -- Return return diff --git a/src/Utilities/Budget.f90 b/src/Utilities/Budget.f90 index 7098d3a2714..e3947909e80 100644 --- a/src/Utilities/Budget.f90 +++ b/src/Utilities/Budget.f90 @@ -1,14 +1,14 @@ -!> @brief This module contains the BudgetModule +!> @brief This module contains the BudgetModule !! !! New entries can be added for each time step, however, the same number of !! entries must be provided, and they must be provided in the same order. If not, !! the module will terminate with an error. -!! +!! !! Maxsize is required as part of the df method and the arrays will be allocated !! to maxsize. If additional entries beyond maxsize are added, the arrays !! will dynamically increase in size, however, to avoid allocation and copying, !! it is best to set maxsize large enough up front. -!! +!! !! vbvl(1, :) contains cumulative rate in !! vbvl(2, :) contains cumulative rate out !! vbvl(3, :) contains rate in @@ -20,20 +20,20 @@ module BudgetModule use KindModule, only: DP, I4B - use SimModule, only: store_error, count_errors + use SimModule, only: store_error, count_errors use ConstantsModule, only: LINELENGTH, LENBUDTXT, LENBUDROWLABEL, DZERO, & DTWO, DHUNDRED - + implicit none private public :: BudgetType public :: budget_cr public :: rate_accumulator - !> @brief Derived type for the Budget object + !> @brief Derived type for the Budget object !! - !! This derived type stores and prints information about a - !! model budget. + !! This derived type stores and prints information about a + !! model budget. !! !< type BudgetType @@ -41,11 +41,12 @@ module BudgetModule integer(I4B), pointer :: maxsize => null() real(DP), pointer :: budperc => null() logical, pointer :: written_once => null() - real(DP), dimension(:,:), pointer :: vbvl => null() + real(DP), dimension(:, :), pointer :: vbvl => null() character(len=LENBUDTXT), dimension(:), pointer, contiguous :: vbnm => null() character(len=20), pointer :: bdtype => null() character(len=5), pointer :: bddim => null() - character(len=LENBUDROWLABEL), dimension(:), pointer, contiguous :: rowlabel => null() + character(len=LENBUDROWLABEL), & + dimension(:), pointer, contiguous :: rowlabel => null() character(len=16), pointer :: labeltitle => null() character(len=20), pointer :: bdzone => null() logical, pointer :: labeled => null() @@ -53,7 +54,7 @@ module BudgetModule ! -- csv output integer(I4B), pointer :: ibudcsv => null() integer(I4B), pointer :: icsvheader => null() - + contains procedure :: budget_df procedure :: budget_ot @@ -65,28 +66,28 @@ module BudgetModule generic :: addentry => add_single_entry, add_multi_entry procedure :: writecsv ! -- private - procedure :: allocate_scalars + procedure :: allocate_scalars procedure, private :: allocate_arrays procedure, private :: resize procedure, private :: write_csv_header end type BudgetType - contains +contains !> @ brief Create a new budget object !! - !! Create a new budget object. + !! Create a new budget object. !! !< subroutine budget_cr(this, name_model) ! -- modules ! -- dummy - type(BudgetType), pointer :: this !< BudgetType object - character(len=*), intent(in) :: name_model !< name of the model + type(BudgetType), pointer :: this !< BudgetType object + character(len=*), intent(in) :: name_model !< name of the model ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- Allocate scalars call this%allocate_scalars(name_model) @@ -97,16 +98,16 @@ end subroutine budget_cr !> @ brief Define information for this object !! - !! Allocate arrays and set member variables + !! Allocate arrays and set member variables !! !< subroutine budget_df(this, maxsize, bdtype, bddim, labeltitle, bdzone) - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: maxsize !< maximum size of budget arrays - character(len=*), optional :: bdtype !< type of budget, default is VOLUME - character(len=*), optional :: bddim !< dimensions of terms, default is L**3 - character(len=*), optional :: labeltitle !< budget label, default is PACKAGE NAME - character(len=*), optional :: bdzone !< corresponding zone, default is ENTIRE MODEL + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: maxsize !< maximum size of budget arrays + character(len=*), optional :: bdtype !< type of budget, default is VOLUME + character(len=*), optional :: bddim !< dimensions of terms, default is L**3 + character(len=*), optional :: labeltitle !< budget label, default is PACKAGE NAME + character(len=*), optional :: bdzone !< corresponding zone, default is ENTIRE MODEL ! ! -- Set values this%maxsize = maxsize @@ -115,62 +116,62 @@ subroutine budget_df(this, maxsize, bdtype, bddim, labeltitle, bdzone) call this%allocate_arrays() ! ! -- Set the budget type - if(present(bdtype)) then + if (present(bdtype)) then this%bdtype = bdtype else this%bdtype = 'VOLUME' - endif + end if ! ! -- Set the budget dimension - if(present(bddim)) then + if (present(bddim)) then this%bddim = bddim else this%bddim = 'L**3' - endif + end if ! ! -- Set the budget zone - if(present(bdzone)) then + if (present(bdzone)) then this%bdzone = bdzone else this%bdzone = 'ENTIRE MODEL' - endif + end if ! ! -- Set the label title - if(present(labeltitle)) then + if (present(labeltitle)) then this%labeltitle = labeltitle else this%labeltitle = 'PACKAGE NAME' - endif + end if ! ! -- Return return end subroutine budget_df - + !> @ brief Convert a number to a string !! - !! This is sometimes needed to avoid numbers that do not fit + !! This is sometimes needed to avoid numbers that do not fit !! correctly into a text string !! !< subroutine value_to_string(val, string, big, small) - real(DP), intent(in) :: val !< value to convert - character(len=*), intent(out) :: string !< string to fill - real(DP), intent(in) :: big !< big value - real(DP), intent(in) :: small !< small value + real(DP), intent(in) :: val !< value to convert + character(len=*), intent(out) :: string !< string to fill + real(DP), intent(in) :: big !< big value + real(DP), intent(in) :: small !< small value real(DP) :: absval ! absval = abs(val) if (val /= DZERO .and. (absval >= big .or. absval < small)) then if (absval >= 1.D100 .or. absval <= 1.D-100) then - ! -- if exponent has 3 digits, then need to explicitly use the ES + ! -- if exponent has 3 digits, then need to explicitly use the ES ! format to force writing the E character - write(string, '(es17.4E3)') val + write (string, '(es17.4E3)') val else - write(string, '(1pe17.4)') val + write (string, '(1pe17.4)') val end if else ! -- value is within range where number looks good with F format - write(string, '(f17.4)') val + write (string, '(f17.4)') val end if return end subroutine value_to_string @@ -182,14 +183,14 @@ end subroutine value_to_string !! !< subroutine budget_ot(this, kstp, kper, iout) - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: kstp !< time step - integer(I4B), intent(in) :: kper !< stress period - integer(I4B), intent(in) :: iout !< output unit number + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: kstp !< time step + integer(I4B), intent(in) :: kper !< stress period + integer(I4B), intent(in) :: iout !< output unit number character(len=17) :: val1, val2 integer(I4B) :: msum1, l - real(DP) :: two, hund, bigvl1, bigvl2, small, & - totrin, totrot, totvin, totvot, diffr, adiffr, & + real(DP) :: two, hund, bigvl1, bigvl2, small, & + totrin, totrot, totvin, totvot, diffr, adiffr, & pdiffr, pdiffv, avgrat, diffv, adiffv, avgvol ! ! -- Set constants @@ -202,7 +203,7 @@ subroutine budget_ot(this, kstp, kper, iout) ! -- Determine number of individual budget entries. this%budperc = DZERO msum1 = this%msum - 1 - if(msum1 <= 0) return + if (msum1 <= 0) return ! ! -- Clear rate and volume accumulators. totrin = DZERO @@ -211,65 +212,65 @@ subroutine budget_ot(this, kstp, kper, iout) totvot = DZERO ! ! -- Add rates and volumes (in and out) to accumulators. - do l=1,msum1 - totrin = totrin + this%vbvl(3,l) - totrot = totrot + this%vbvl(4,l) - totvin = totvin + this%vbvl(1,l) - totvot = totvot + this%vbvl(2,l) - enddo + do l = 1, msum1 + totrin = totrin + this%vbvl(3, l) + totrot = totrot + this%vbvl(4, l) + totvin = totvin + this%vbvl(1, l) + totvot = totvot + this%vbvl(2, l) + end do ! ! -- Print time step number and stress period number. - if(this%labeled) then - write(iout,261) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & - kstp, kper - write(iout,266) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & - trim(adjustl(this%bddim)),this%labeltitle + if (this%labeled) then + write (iout, 261) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & + kstp, kper + write (iout, 266) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & + trim(adjustl(this%bddim)), this%labeltitle else - write(iout,260) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & - kstp, kper - write(iout,265) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & - trim(adjustl(this%bddim)) - endif + write (iout, 260) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & + kstp, kper + write (iout, 265) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & + trim(adjustl(this%bddim)) + end if ! ! -- Print individual inflow rates and volumes and their totals. - do l=1,msum1 + do l = 1, msum1 call value_to_string(this%vbvl(1, l), val1, bigvl1, small) call value_to_string(this%vbvl(3, l), val2, bigvl1, small) - if(this%labeled) then - write(iout,276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) + if (this%labeled) then + write (iout, 276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) else - write(iout,275) this%vbnm(l), val1, this%vbnm(l), val2 - endif - enddo + write (iout, 275) this%vbnm(l), val1, this%vbnm(l), val2 + end if + end do call value_to_string(totvin, val1, bigvl1, small) call value_to_string(totrin, val2, bigvl1, small) - write(iout,286) val1, val2 + write (iout, 286) val1, val2 ! ! -- Print individual outflow rates and volumes and their totals. - write(iout,287) - do l=1,msum1 - call value_to_string(this%vbvl(2,l), val1, bigvl1, small) - call value_to_string(this%vbvl(4,l), val2, bigvl1, small) - if(this%labeled) then - write(iout,276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) + write (iout, 287) + do l = 1, msum1 + call value_to_string(this%vbvl(2, l), val1, bigvl1, small) + call value_to_string(this%vbvl(4, l), val2, bigvl1, small) + if (this%labeled) then + write (iout, 276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) else - write(iout,275) this%vbnm(l), val1, this%vbnm(l), val2 - endif - enddo + write (iout, 275) this%vbnm(l), val1, this%vbnm(l), val2 + end if + end do call value_to_string(totvot, val1, bigvl1, small) call value_to_string(totrot, val2, bigvl1, small) - write(iout,298) val1, val2 + write (iout, 298) val1, val2 ! ! -- Calculate the difference between inflow and outflow. ! ! -- Calculate difference between rate in and rate out. - diffr=totrin-totrot - adiffr=abs(diffr) + diffr = totrin - totrot + adiffr = abs(diffr) ! ! -- Calculate percent difference between rate in and rate out. pdiffr = DZERO - avgrat=(totrin+totrot)/two - if(avgrat /= DZERO) pdiffr = hund * diffr / avgrat + avgrat = (totrin + totrot) / two + if (avgrat /= DZERO) pdiffr = hund * diffr / avgrat this%budperc = pdiffr ! ! -- Calculate difference between volume in and volume out. @@ -278,42 +279,42 @@ subroutine budget_ot(this, kstp, kper, iout) ! ! -- Get percent difference between volume in and volume out. pdiffv = DZERO - avgvol=(totvin+totvot)/two - if(avgvol /= DZERO) pdiffv= hund * diffv / avgvol + avgvol = (totvin + totvot) / two + if (avgvol /= DZERO) pdiffv = hund * diffv / avgvol ! ! -- Print differences and percent differences between input ! -- and output rates and volumes. call value_to_string(diffv, val1, bigvl2, small) call value_to_string(diffr, val2, bigvl2, small) - write(iout,299) val1, val2 - write(iout,300) pdiffv, pdiffr + write (iout, 299) val1, val2 + write (iout, 300) pdiffv, pdiffr ! ! -- flush the file - flush(iout) + flush (iout) ! ! -- set written_once to .true. this%written_once = .true. ! ! -- formats - 260 FORMAT(//2X,a,' BUDGET FOR ',a,' AT END OF' & - ,' TIME STEP',I5,', STRESS PERIOD',I4/2X,78('-')) - 261 FORMAT(//2X,a,' BUDGET FOR ',a,' AT END OF' & - ,' TIME STEP',I5,', STRESS PERIOD',I4/2X,99('-')) - 265 FORMAT(1X,/5X,'CUMULATIVE ',a,6X,a,7X & - ,'RATES FOR THIS TIME STEP',6X,a,'/T'/5X,18('-'),17X,24('-') & - //11X,'IN:',38X,'IN:'/11X,'---',38X,'---') - 266 FORMAT(1X,/5X,'CUMULATIVE ',a,6X,a,7X & - ,'RATES FOR THIS TIME STEP',6X,a,'/T',10X,A16, & - /5X,18('-'),17X,24('-'),21X,16('-') & - //11X,'IN:',38X,'IN:'/11X,'---',38X,'---') - 275 FORMAT(1X,3X,A16,' =',A17,6X,A16,' =',A17) - 276 FORMAT(1X,3X,A16,' =',A17,6X,A16,' =',A17,5X,A) - 286 FORMAT(1X,/12X,'TOTAL IN =',A,14X,'TOTAL IN =',A) - 287 FORMAT(1X,/10X,'OUT:',37X,'OUT:'/10X,4('-'),37X,4('-')) - 298 FORMAT(1X,/11X,'TOTAL OUT =',A,13X,'TOTAL OUT =',A) - 299 FORMAT(1X,/12X,'IN - OUT =',A,14X,'IN - OUT =',A) - 300 FORMAT(1X,/1X,'PERCENT DISCREPANCY =',F15.2 & - ,5X,'PERCENT DISCREPANCY =',F15.2/) +260 FORMAT(//2X, a, ' BUDGET FOR ', a, ' AT END OF' & + , ' TIME STEP', I5, ', STRESS PERIOD', I4 / 2X, 78('-')) +261 FORMAT(//2X, a, ' BUDGET FOR ', a, ' AT END OF' & + , ' TIME STEP', I5, ', STRESS PERIOD', I4 / 2X, 99('-')) +265 FORMAT(1X, /5X, 'CUMULATIVE ', a, 6X, a, 7X & + , 'RATES FOR THIS TIME STEP', 6X, a, '/T'/5X, 18('-'), 17X, 24('-') & + //11X, 'IN:', 38X, 'IN:'/11X, '---', 38X, '---') +266 FORMAT(1X, /5X, 'CUMULATIVE ', a, 6X, a, 7X & + , 'RATES FOR THIS TIME STEP', 6X, a, '/T', 10X, A16, & + /5X, 18('-'), 17X, 24('-'), 21X, 16('-') & + //11X, 'IN:', 38X, 'IN:'/11X, '---', 38X, '---') +275 FORMAT(1X, 3X, A16, ' =', A17, 6X, A16, ' =', A17) +276 FORMAT(1X, 3X, A16, ' =', A17, 6X, A16, ' =', A17, 5X, A) +286 FORMAT(1X, /12X, 'TOTAL IN =', A, 14X, 'TOTAL IN =', A) +287 FORMAT(1X, /10X, 'OUT:', 37X, 'OUT:'/10X, 4('-'), 37X, 4('-')) +298 FORMAT(1X, /11X, 'TOTAL OUT =', A, 13X, 'TOTAL OUT =', A) +299 FORMAT(1X, /12X, 'IN - OUT =', A, 14X, 'IN - OUT =', A) +300 FORMAT(1X, /1X, 'PERCENT DISCREPANCY =', F15.2 & + , 5X, 'PERCENT DISCREPANCY =', F15.2/) ! ! -- Return return @@ -325,25 +326,25 @@ end subroutine budget_ot !! !< subroutine budget_da(this) - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! ! -- Scalars - deallocate(this%msum) - deallocate(this%maxsize) - deallocate(this%budperc) - deallocate(this%written_once) - deallocate(this%labeled) - deallocate(this%bdtype) - deallocate(this%bddim) - deallocate(this%labeltitle) - deallocate(this%bdzone) - deallocate(this%ibudcsv) - deallocate(this%icsvheader) + deallocate (this%msum) + deallocate (this%maxsize) + deallocate (this%budperc) + deallocate (this%written_once) + deallocate (this%labeled) + deallocate (this%bdtype) + deallocate (this%bddim) + deallocate (this%labeltitle) + deallocate (this%bdzone) + deallocate (this%ibudcsv) + deallocate (this%icsvheader) ! ! -- Arrays - deallocate(this%vbvl) - deallocate(this%vbnm) - deallocate(this%rowlabel) + deallocate (this%vbvl) + deallocate (this%vbnm) + deallocate (this%rowlabel) ! ! -- Return return @@ -357,7 +358,7 @@ end subroutine budget_da subroutine reset(this) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! -- local integer(I4B) :: i ! @@ -366,13 +367,13 @@ subroutine reset(this) do i = 1, this%maxsize this%vbvl(3, i) = DZERO this%vbvl(4, i) = DZERO - enddo + end do ! ! -- Return return end subroutine reset - !> @ brief Add a single row of information + !> @ brief Add a single row of information !! !! Add information corresponding to one row in the budget table !! rin the inflow rate @@ -381,32 +382,32 @@ end subroutine reset !! text is the name of the entry !! isupress_accumulate is an optional flag. If specified as 1, then !! the volume is NOT added to the accumulators on vbvl(1, :) and vbvl(2, :). - !! rowlabel is a LENBUDROWLABEL character text entry that is written to the - !! right of the table. It can be used for adding package names to budget + !! rowlabel is a LENBUDROWLABEL character text entry that is written to the + !! right of the table. It can be used for adding package names to budget !! entries. !! !< - subroutine add_single_entry(this, rin, rout, delt, text, & + subroutine add_single_entry(this, rin, rout, delt, text, & isupress_accumulate, rowlabel) ! -- dummy - class(BudgetType) :: this !< BudgetType object - real(DP), intent(in) :: rin !< inflow rate - real(DP), intent(in) :: rout !< outflow rate - real(DP), intent(in) :: delt !< time step length - character(len=LENBUDTXT), intent(in) :: text !< name of the entry - integer(I4B), optional, intent(in) :: isupress_accumulate !< accumulate flag - character(len=*), optional, intent(in) :: rowlabel !< row label + class(BudgetType) :: this !< BudgetType object + real(DP), intent(in) :: rin !< inflow rate + real(DP), intent(in) :: rout !< outflow rate + real(DP), intent(in) :: delt !< time step length + character(len=LENBUDTXT), intent(in) :: text !< name of the entry + integer(I4B), optional, intent(in) :: isupress_accumulate !< accumulate flag + character(len=*), optional, intent(in) :: rowlabel !< row label ! -- local character(len=LINELENGTH) :: errmsg character(len=*), parameter :: fmtbuderr = & - "('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" + &"('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" integer(I4B) :: iscv integer(I4B) :: maxsize ! iscv = 0 - if(present(isupress_accumulate)) then + if (present(isupress_accumulate)) then iscv = isupress_accumulate - endif + end if ! ! -- ensure budget arrays are large enough maxsize = this%msum @@ -416,33 +417,33 @@ subroutine add_single_entry(this, rin, rout, delt, text, & ! ! -- If budget has been written at least once, then make sure that the present ! text entry matches the last text entry - if(this%written_once) then - if(trim(adjustl(this%vbnm(this%msum))) /= trim(adjustl(text))) then - write(errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & - trim(adjustl(text)) + if (this%written_once) then + if (trim(adjustl(this%vbnm(this%msum))) /= trim(adjustl(text))) then + write (errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & + trim(adjustl(text)) call store_error(errmsg, terminate=.TRUE.) - endif - endif + end if + end if ! - if(iscv == 0) then - this%vbvl(1, this%msum)=this%vbvl(1,this%msum) + rin * delt - this%vbvl(2, this%msum)=this%vbvl(2,this%msum) + rout * delt - endif + if (iscv == 0) then + this%vbvl(1, this%msum) = this%vbvl(1, this%msum) + rin * delt + this%vbvl(2, this%msum) = this%vbvl(2, this%msum) + rout * delt + end if ! this%vbvl(3, this%msum) = rin this%vbvl(4, this%msum) = rout this%vbnm(this%msum) = adjustr(text) - if(present(rowlabel)) then + if (present(rowlabel)) then this%rowlabel(this%msum) = adjustl(rowlabel) this%labeled = .true. - endif + end if this%msum = this%msum + 1 ! ! -- Return return end subroutine add_single_entry - !> @ brief Add multiple rows of information + !> @ brief Add multiple rows of information !! !! Add information corresponding to one multiple rows in the budget table !! budterm is an array with inflow in column 1 and outflow in column 2 @@ -451,31 +452,31 @@ end subroutine add_single_entry !! row in budterm !! isupress_accumulate is an optional flag. If specified as 1, then !! the volume is NOT added to the accumulators on vbvl(1, :) and vbvl(2, :). - !! rowlabel is a LENBUDROWLABEL character text entry that is written to the - !! right of the table. It can be used for adding package names to budget + !! rowlabel is a LENBUDROWLABEL character text entry that is written to the + !! right of the table. It can be used for adding package names to budget !! entries. For multiple entries, the same rowlabel is used for each entry. !! !< - subroutine add_multi_entry(this, budterm, delt, budtxt, & + subroutine add_multi_entry(this, budterm, delt, budtxt, & isupress_accumulate, rowlabel) ! -- dummy - class(BudgetType) :: this !< BudgetType object - real(DP), dimension(:, :), intent(in) :: budterm !< array of budget terms - real(DP), intent(in) :: delt !< time step length - character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt !< name of the entries - integer(I4B), optional, intent(in) :: isupress_accumulate !< suppress accumulate - character(len=*), optional, intent(in) :: rowlabel !< row label + class(BudgetType) :: this !< BudgetType object + real(DP), dimension(:, :), intent(in) :: budterm !< array of budget terms + real(DP), intent(in) :: delt !< time step length + character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt !< name of the entries + integer(I4B), optional, intent(in) :: isupress_accumulate !< suppress accumulate + character(len=*), optional, intent(in) :: rowlabel !< row label ! -- local character(len=LINELENGTH) :: errmsg character(len=*), parameter :: fmtbuderr = & - "('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" + &"('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" integer(I4B) :: iscv, i integer(I4B) :: nbudterms, maxsize ! iscv = 0 - if(present(isupress_accumulate)) then + if (present(isupress_accumulate)) then iscv = isupress_accumulate - endif + end if ! ! -- ensure budget arrays are large enough nbudterms = size(budtxt) @@ -489,35 +490,35 @@ subroutine add_multi_entry(this, budterm, delt, budtxt, & ! ! -- If budget has been written at least once, then make sure that the present ! text entry matches the last text entry - if(this%written_once) then - if(trim(adjustl(this%vbnm(this%msum))) /= & - trim(adjustl(budtxt(i)))) then - write(errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & - trim(adjustl(budtxt(i))) - call store_error(errmsg) - endif - endif + if (this%written_once) then + if (trim(adjustl(this%vbnm(this%msum))) /= & + trim(adjustl(budtxt(i)))) then + write (errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & + trim(adjustl(budtxt(i))) + call store_error(errmsg) + end if + end if ! - if(iscv == 0) then - this%vbvl(1, this%msum)=this%vbvl(1,this%msum) + budterm(1, i) * delt - this%vbvl(2, this%msum)=this%vbvl(2,this%msum) + budterm(2, i) * delt - endif + if (iscv == 0) then + this%vbvl(1, this%msum) = this%vbvl(1, this%msum) + budterm(1, i) * delt + this%vbvl(2, this%msum) = this%vbvl(2, this%msum) + budterm(2, i) * delt + end if ! this%vbvl(3, this%msum) = budterm(1, i) this%vbvl(4, this%msum) = budterm(2, i) this%vbnm(this%msum) = adjustr(budtxt(i)) - if(present(rowlabel)) then + if (present(rowlabel)) then this%rowlabel(this%msum) = adjustl(rowlabel) this%labeled = .true. - endif + end if this%msum = this%msum + 1 ! - enddo + end do ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error('Could not add multi-entry', terminate=.TRUE.) - endif + end if ! ! -- Return return @@ -531,20 +532,20 @@ end subroutine add_multi_entry subroutine allocate_scalars(this, name_model) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - character(len=*), intent(in) :: name_model !< name of the model - ! - allocate(this%msum) - allocate(this%maxsize) - allocate(this%budperc) - allocate(this%written_once) - allocate(this%labeled) - allocate(this%bdtype) - allocate(this%bddim) - allocate(this%labeltitle) - allocate(this%bdzone) - allocate(this%ibudcsv) - allocate(this%icsvheader) + class(BudgetType) :: this !< BudgetType object + character(len=*), intent(in) :: name_model !< name of the model + ! + allocate (this%msum) + allocate (this%maxsize) + allocate (this%budperc) + allocate (this%written_once) + allocate (this%labeled) + allocate (this%bdtype) + allocate (this%bddim) + allocate (this%labeltitle) + allocate (this%bdzone) + allocate (this%ibudcsv) + allocate (this%icsvheader) ! ! -- Initialize values this%msum = 0 @@ -569,26 +570,26 @@ end subroutine allocate_scalars subroutine allocate_arrays(this) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! ! -- If redefining, then need to deallocate/reallocate - if(associated(this%vbvl)) then - deallocate(this%vbvl) - nullify(this%vbvl) - endif - if(associated(this%vbnm)) then - deallocate(this%vbnm) - nullify(this%vbnm) - endif - if(associated(this%rowlabel)) then - deallocate(this%rowlabel) - nullify(this%rowlabel) - endif + if (associated(this%vbvl)) then + deallocate (this%vbvl) + nullify (this%vbvl) + end if + if (associated(this%vbnm)) then + deallocate (this%vbnm) + nullify (this%vbnm) + end if + if (associated(this%rowlabel)) then + deallocate (this%rowlabel) + nullify (this%rowlabel) + end if ! ! -- Allocate - allocate(this%vbvl(4, this%maxsize)) - allocate(this%vbnm(this%maxsize)) - allocate(this%rowlabel(this%maxsize)) + allocate (this%vbvl(4, this%maxsize)) + allocate (this%vbnm(this%maxsize)) + allocate (this%rowlabel(this%maxsize)) ! ! -- Initialize values this%vbvl(:, :) = DZERO @@ -597,7 +598,7 @@ subroutine allocate_arrays(this) ! return end subroutine allocate_arrays - + !> @ brief Resize the budget object !! !! If the size wasn't allocated to be large enough, then the budget object @@ -607,8 +608,8 @@ end subroutine allocate_arrays subroutine resize(this, maxsize) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: maxsize !< maximum size + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: maxsize !< maximum size ! -- local real(DP), dimension(:, :), allocatable :: vbvl character(len=LENBUDTXT), dimension(:), allocatable :: vbnm @@ -617,9 +618,9 @@ subroutine resize(this, maxsize) ! ! -- allocate and copy into local storage maxsizeold = this%maxsize - allocate(vbvl(4, maxsizeold)) - allocate(vbnm(maxsizeold)) - allocate(rowlabel(maxsizeold)) + allocate (vbvl(4, maxsizeold)) + allocate (vbnm(maxsizeold)) + allocate (rowlabel(maxsizeold)) vbvl(:, :) = this%vbvl(:, :) vbnm(:) = this%vbnm(:) rowlabel(:) = this%rowlabel(:) @@ -634,14 +635,14 @@ subroutine resize(this, maxsize) this%rowlabel(1:maxsizeold) = rowlabel(1:maxsizeold) ! ! - deallocate local copies - deallocate(vbvl) - deallocate(vbnm) - deallocate(rowlabel) + deallocate (vbvl) + deallocate (vbnm) + deallocate (rowlabel) ! ! -- return return end subroutine resize - + !> @ brief Rate accumulator subroutine !! !! Routing for tallying inflows and outflows of an array @@ -650,9 +651,9 @@ end subroutine resize subroutine rate_accumulator(flow, rin, rout) ! -- modules ! -- dummy - real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flows - real(DP), intent(out) :: rin !< calculated sum of inflows - real(DP), intent(out) :: rout !< calculated sum of outflows + real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flows + real(DP), intent(out) :: rin !< calculated sum of inflows + real(DP), intent(out) :: rout !< calculated sum of outflows integer(I4B) :: n ! rin = DZERO @@ -666,7 +667,7 @@ subroutine rate_accumulator(flow, rin, rout) end do return end subroutine rate_accumulator - + !> @ brief Set unit number for csv output file !! !! This routine can be used to activate csv output @@ -676,12 +677,12 @@ end subroutine rate_accumulator subroutine set_ibudcsv(this, ibudcsv) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: ibudcsv !< unit number for csv budget output + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: ibudcsv !< unit number for csv budget output this%ibudcsv = ibudcsv return end subroutine set_ibudcsv - + !> @ brief Write csv output !! !! This routine will write a row of output to the @@ -692,8 +693,8 @@ end subroutine set_ibudcsv subroutine writecsv(this, totim) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - real(DP), intent(in) :: totim !< time corresponding to this data + class(BudgetType) :: this !< BudgetType object + real(DP), intent(in) :: totim !< time corresponding to this data ! -- local integer(I4B) :: i real(DP) :: totrin @@ -727,19 +728,20 @@ subroutine writecsv(this, totim) end if ! ! -- write data - write(this%ibudcsv, '(*(G0,:,","))') totim, & - (this%vbvl(3, i), i=1,this%msum-1), & - (this%vbvl(4, i), i=1,this%msum-1), & - totrin, totrout, pdiffr + write (this%ibudcsv, '(*(G0,:,","))') & + totim, & + (this%vbvl(3, i), i=1, this%msum - 1), & + (this%vbvl(4, i), i=1, this%msum - 1), & + totrin, totrout, pdiffr ! ! -- flush the file - flush(this%ibudcsv) + flush (this%ibudcsv) end if ! ! -- return return end subroutine writecsv - + !> @ brief Write csv header !! !! This routine will write the csv header based on the @@ -749,21 +751,21 @@ end subroutine writecsv subroutine write_csv_header(this) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! -- local integer(I4B) :: l character(len=LINELENGTH) :: txt, txtl - write(this%ibudcsv, '(a)', advance='NO') 'time,' + write (this%ibudcsv, '(a)', advance='NO') 'time,' ! ! -- first write IN do l = 1, this%msum - 1 txt = this%vbnm(l) txtl = '' if (this%labeled) then - txtl = '(' // trim(adjustl(this%rowlabel(l))) // ')' + txtl = '('//trim(adjustl(this%rowlabel(l)))//')' end if - txt = trim(adjustl(txt)) // trim(adjustl(txtl)) // '_IN,' - write(this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) + txt = trim(adjustl(txt))//trim(adjustl(txtl))//'_IN,' + write (this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) end do ! ! -- then write OUT @@ -771,12 +773,12 @@ subroutine write_csv_header(this) txt = this%vbnm(l) txtl = '' if (this%labeled) then - txtl = '(' // trim(adjustl(this%rowlabel(l))) // ')' + txtl = '('//trim(adjustl(this%rowlabel(l)))//')' end if - txt = trim(adjustl(txt)) // trim(adjustl(txtl)) // '_OUT,' - write(this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) + txt = trim(adjustl(txt))//trim(adjustl(txtl))//'_OUT,' + write (this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) end do - write(this%ibudcsv, '(a)') 'TOTAL_IN,TOTAL_OUT,PERCENT_DIFFERENCE' + write (this%ibudcsv, '(a)') 'TOTAL_IN,TOTAL_OUT,PERCENT_DIFFERENCE' ! ! -- return return diff --git a/src/Utilities/BudgetFileReader.f90 b/src/Utilities/BudgetFileReader.f90 index be959e66efa..413ded4faa9 100644 --- a/src/Utilities/BudgetFileReader.f90 +++ b/src/Utilities/BudgetFileReader.f90 @@ -5,12 +5,12 @@ module BudgetFileReaderModule use ConstantsModule, only: LINELENGTH implicit none - + private public :: BudgetFileReaderType - + type :: BudgetFileReaderType - + logical :: hasimeth1flowja = .false. integer(I4B) :: inunit integer(I4B) :: nbudterms @@ -45,17 +45,17 @@ module BudgetFileReaderModule character(len=16) :: dstmodelname character(len=16) :: dstpackagename character(len=16), dimension(:), allocatable :: dstpackagenamearray - + contains - + procedure :: initialize procedure :: read_record procedure :: finalize - + end type BudgetFileReaderType - - contains - + +contains + subroutine initialize(this, iu, iout, ncrbud) ! ****************************************************************************** ! initialize @@ -82,8 +82,8 @@ subroutine initialize(this, iu, iout, ncrbud) ! ! -- Determine number of budget terms within a time step if (iout > 0) & - write(iout, '(a)') & - 'Reading budget file to determine number of terms per time step.' + write (iout, '(a)') & + 'Reading budget file to determine number of terms per time step.' ! ! -- Read through the first set of data for time step 1 and stress period 1 do @@ -96,13 +96,13 @@ subroutine initialize(this, iu, iout, ncrbud) end do kstp_last = this%kstp kper_last = this%kper - allocate(this%budtxtarray(this%nbudterms)) - allocate(this%imetharray(this%nbudterms)) - allocate(this%dstpackagenamearray(this%nbudterms)) - allocate(this%nauxarray(this%nbudterms)) - allocate(this%auxtxtarray(maxaux, this%nbudterms)) + allocate (this%budtxtarray(this%nbudterms)) + allocate (this%imetharray(this%nbudterms)) + allocate (this%dstpackagenamearray(this%nbudterms)) + allocate (this%nauxarray(this%nbudterms)) + allocate (this%auxtxtarray(maxaux, this%nbudterms)) this%auxtxtarray(:, :) = '' - rewind(this%inunit) + rewind (this%inunit) ! ! -- Now read through again and store budget text names do ibudterm = 1, this%nbudterms @@ -116,18 +116,18 @@ subroutine initialize(this, iu, iout, ncrbud) this%auxtxtarray(1:this%naux, ibudterm) = this%auxtxt(:) end if if (this%srcmodelname == this%dstmodelname) then - if(allocated(this%nodesrc)) ncrbud = max(ncrbud, maxval(this%nodesrc)) - endif - enddo - rewind(this%inunit) + if (allocated(this%nodesrc)) ncrbud = max(ncrbud, maxval(this%nodesrc)) + end if + end do + rewind (this%inunit) if (iout > 0) & - write(iout, '(a, i0, a)') 'Detected ', this%nbudterms, & + write (iout, '(a, i0, a)') 'Detected ', this%nbudterms, & ' unique flow terms in budget file.' ! ! -- return return end subroutine initialize - + subroutine read_record(this, success, iout_opt) ! ****************************************************************************** ! read_record @@ -150,7 +150,7 @@ subroutine read_record(this, success, iout_opt) iout = iout_opt else iout = 0 - endif + end if ! this%kstp = 0 this%kper = 0 @@ -163,83 +163,83 @@ subroutine read_record(this, success, iout_opt) this%srcpackagename = '' this%dstmodelname = '' this%dstpackagename = '' - + success = .true. this%kstpnext = 0 this%kpernext = 0 - read(this%inunit, iostat=iostat) this%kstp, this%kper, this%budtxt, & + read (this%inunit, iostat=iostat) this%kstp, this%kper, this%budtxt, & this%nval, this%idum1, this%idum2 if (iostat /= 0) then success = .false. if (iostat < 0) this%endoffile = .true. return - endif - read(this%inunit) this%imeth, this%delt, this%pertim, this%totim - if(this%imeth == 1) then + end if + read (this%inunit) this%imeth, this%delt, this%pertim, this%totim + if (this%imeth == 1) then if (trim(adjustl(this%budtxt)) == 'FLOW-JA-FACE') then - if(allocated(this%flowja)) deallocate(this%flowja) - allocate(this%flowja(this%nval)) - read(this%inunit) this%flowja + if (allocated(this%flowja)) deallocate (this%flowja) + allocate (this%flowja(this%nval)) + read (this%inunit) this%flowja this%hasimeth1flowja = .true. else this%nval = this%nval * this%idum1 * abs(this%idum2) - if(allocated(this%flow)) deallocate(this%flow) - allocate(this%flow(this%nval)) - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - allocate(this%nodesrc(this%nval)) - read(this%inunit) this%flow + if (allocated(this%flow)) deallocate (this%flow) + allocate (this%flow(this%nval)) + if (allocated(this%nodesrc)) deallocate (this%nodesrc) + allocate (this%nodesrc(this%nval)) + read (this%inunit) this%flow do i = 1, this%nval this%nodesrc(i) = i - enddo - endif + end do + end if elseif (this%imeth == 6) then ! -- method code 6 - read(this%inunit) this%srcmodelname - read(this%inunit) this%srcpackagename - read(this%inunit) this%dstmodelname - read(this%inunit) this%dstpackagename - read(this%inunit) this%ndat + read (this%inunit) this%srcmodelname + read (this%inunit) this%srcpackagename + read (this%inunit) this%dstmodelname + read (this%inunit) this%dstpackagename + read (this%inunit) this%ndat this%naux = this%ndat - 1 - if(allocated(this%auxtxt)) deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) - read(this%inunit) this%auxtxt - read(this%inunit) this%nlist - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - allocate(this%nodesrc(this%nlist)) - if(allocated(this%nodedst)) deallocate(this%nodedst) - allocate(this%nodedst(this%nlist)) - if(allocated(this%flow)) deallocate(this%flow) - allocate(this%flow(this%nlist)) - if(allocated(this%auxvar)) deallocate(this%auxvar) - allocate(this%auxvar(this%naux, this%nlist)) - read(this%inunit) (this%nodesrc(n), this%nodedst(n), this%flow(n), & - (this%auxvar(i, n), i = 1, this%naux), n = 1, this%nlist) + if (allocated(this%auxtxt)) deallocate (this%auxtxt) + allocate (this%auxtxt(this%naux)) + read (this%inunit) this%auxtxt + read (this%inunit) this%nlist + if (allocated(this%nodesrc)) deallocate (this%nodesrc) + allocate (this%nodesrc(this%nlist)) + if (allocated(this%nodedst)) deallocate (this%nodedst) + allocate (this%nodedst(this%nlist)) + if (allocated(this%flow)) deallocate (this%flow) + allocate (this%flow(this%nlist)) + if (allocated(this%auxvar)) deallocate (this%auxvar) + allocate (this%auxvar(this%naux, this%nlist)) + read (this%inunit) (this%nodesrc(n), this%nodedst(n), this%flow(n), & + (this%auxvar(i, n), i=1, this%naux), n=1, this%nlist) else - write(errmsg, '(a, a)') 'ERROR READING: ', trim(this%budtxt) + write (errmsg, '(a, a)') 'ERROR READING: ', trim(this%budtxt) call store_error(errmsg) - write(errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', this%imeth + write (errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', this%imeth call store_error(errmsg) call store_error_unit(this%inunit) - endif + end if if (iout > 0) then - write(iout, '(1pg15.6, a, 1x, a)') this%totim, this%budtxt, & + write (iout, '(1pg15.6, a, 1x, a)') this%totim, this%budtxt, & this%dstpackagename - endif + end if ! ! -- look ahead to next kstp and kper, then backup if read successfully if (.not. this%endoffile) then - read(this%inunit, iostat=iostat) this%kstpnext, this%kpernext + read (this%inunit, iostat=iostat) this%kstpnext, this%kpernext if (iostat == 0) then call fseek_stream(this%inunit, -2 * I4B, 1, iostat) else if (iostat < 0) then this%endoffile = .true. end if - endif + end if ! ! -- return return end subroutine read_record - + subroutine finalize(this) ! ****************************************************************************** ! budgetdata_finalize @@ -249,16 +249,16 @@ subroutine finalize(this) ! ------------------------------------------------------------------------------ class(BudgetFileReaderType) :: this ! ------------------------------------------------------------------------------ - close(this%inunit) - if(allocated(this%auxtxt)) deallocate(this%auxtxt) - if(allocated(this%flowja)) deallocate(this%flowja) - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - if(allocated(this%nodedst)) deallocate(this%nodedst) - if(allocated(this%flow)) deallocate(this%flow) - if(allocated(this%auxvar)) deallocate(this%auxvar) + close (this%inunit) + if (allocated(this%auxtxt)) deallocate (this%auxtxt) + if (allocated(this%flowja)) deallocate (this%flowja) + if (allocated(this%nodesrc)) deallocate (this%nodesrc) + if (allocated(this%nodedst)) deallocate (this%nodedst) + if (allocated(this%flow)) deallocate (this%flow) + if (allocated(this%auxvar)) deallocate (this%auxvar) ! ! -- return return end subroutine finalize - + end module BudgetFileReaderModule diff --git a/src/Utilities/BudgetObject.f90 b/src/Utilities/BudgetObject.f90 index eefd3e243a0..35836bf50b6 100644 --- a/src/Utilities/BudgetObject.f90 +++ b/src/Utilities/BudgetObject.f90 @@ -1,25 +1,25 @@ -! Comprehensive budget object that stores all of the -! intercell flows, and the inflows and the outflows for +! Comprehensive budget object that stores all of the +! intercell flows, and the inflows and the outflows for ! an advanced package. module BudgetObjectModule - + use KindModule, only: I4B, DP - use ConstantsModule, only: LENBUDTXT, LINELENGTH, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + use ConstantsModule, only: LENBUDTXT, LINELENGTH, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & DZERO, DHALF, DHUNDRED - use BudgetModule, only : BudgetType, budget_cr + use BudgetModule, only: BudgetType, budget_cr use BudgetTermModule, only: BudgetTermType use TableModule, only: TableType, table_cr use BaseDisModule, only: DisBaseType use BudgetFileReaderModule, only: BudgetFileReaderType - + implicit none - + public :: BudgetObjectType public :: budgetobject_cr public :: budgetobject_cr_bfr - + type :: BudgetObjectType ! ! -- name, number of control volumes, and number of budget terms @@ -47,20 +47,20 @@ module BudgetObjectModule ! -- budget table object, for writing the typical MODFLOW budget type(BudgetType), pointer :: budtable => null() ! - ! -- flow table object, for writing the flow budget for + ! -- flow table object, for writing the flow budget for ! each control volume logical, pointer :: add_cellids => null() integer(I4B), pointer :: icellid => null() integer(I4B), pointer :: nflowterms => null() integer(I4B), dimension(:), pointer :: istart => null() integer(I4B), dimension(:), pointer :: iflowterms => null() - type(TableType), pointer :: flowtab => null() + type(TableType), pointer :: flowtab => null() ! ! -- budget file reader, for reading flows from a binary file type(BudgetFileReaderType), pointer :: bfr => null() - + contains - + procedure :: budgetobject_df procedure :: flowtable_df procedure :: accumulate_terms @@ -72,10 +72,10 @@ module BudgetObjectModule procedure :: bfr_init procedure :: bfr_advance procedure :: fill_from_bfr - + end type BudgetObjectType - - contains + +contains subroutine budgetobject_cr(this, name) ! ****************************************************************************** @@ -91,7 +91,7 @@ subroutine budgetobject_cr(this, name) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- initialize variables this%name = name @@ -142,31 +142,31 @@ subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto, & this%nsto = nsto ! ! -- allocate space for budterm - allocate(this%budterm(nbudterm)) + allocate (this%budterm(nbudterm)) ! ! -- Set the budget type to name bdtype = this%name ! ! -- Set the budget dimension - if(present(bddim_opt)) then + if (present(bddim_opt)) then bddim = bddim_opt else bddim = 'L**3' - endif + end if ! ! -- Set the budget zone - if(present(bdzone_opt)) then + if (present(bdzone_opt)) then bdzone = bdzone_opt else bdzone = 'ENTIRE MODEL' - endif + end if ! ! -- Set the label title - if(present(labeltitle_opt)) then + if (present(labeltitle_opt)) then labeltitle = labeltitle_opt else labeltitle = 'PACKAGE NAME' - endif + end if ! ! -- setup the budget table object call this%budtable%budget_df(nbudterm, bdtype, bddim, labeltitle, bdzone) @@ -179,7 +179,7 @@ subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto, & ! -- Return return end subroutine budgetobject_df - + subroutine flowtable_df(this, iout, cellids) ! ****************************************************************************** ! flowtable_df -- Define the new flow table object @@ -215,9 +215,9 @@ subroutine flowtable_df(this, iout, cellids) end if ! ! -- allocate scalars - allocate(this%add_cellids) - allocate(this%icellid) - allocate(this%nflowterms) + allocate (this%add_cellids) + allocate (this%icellid) + allocate (this%nflowterms) ! ! -- initialize scalars this%add_cellids = add_cellids @@ -250,11 +250,11 @@ subroutine flowtable_df(this, iout, cellids) end do ! ! -- allocate arrays - allocate(this%istart(this%nflowterms)) - allocate(this%iflowterms(this%nflowterms)) + allocate (this%istart(this%nflowterms)) + allocate (this%iflowterms(this%nflowterms)) ! ! -- set up flow tableobj - title = trim(this%name) // ' PACKAGE - SUMMARY OF FLOWS FOR ' // & + title = trim(this%name)//' PACKAGE - SUMMARY OF FLOWS FOR '// & 'EACH CONTROL VOLUME' call table_cr(this%flowtab, this%name, title) call this%flowtab%table_df(this%ncv, maxcol, iout, transient=.TRUE.) @@ -298,7 +298,7 @@ subroutine flowtable_df(this, iout, cellids) ! -- Return return end subroutine flowtable_df - + subroutine accumulate_terms(this) ! ****************************************************************************** ! accumulate_terms -- add up accumulators and submit to budget table @@ -311,7 +311,7 @@ subroutine accumulate_terms(this) ! -- dummy class(BudgetObjectType) :: this ! -- dummy - character(len=LENBUDTXT) :: flowtype + character(len=LENBUDTXT) :: flowtype integer(I4B) :: i real(DP) :: ratin, ratout ! ------------------------------------------------------------------------------ @@ -404,9 +404,9 @@ subroutine write_flowtable(this, dis, kstp, kper, cellidstr) cellid = cellidstr(icv) else ! - ! -- Determine the cellid for this entry. The cellid, such as + ! -- Determine the cellid for this entry. The cellid, such as ! (1, 10, 10), is assumed to be in the id2 column of this budterm. - j = this%icellid + j = this%icellid idx = this%iflowterms(j) i = this%istart(j) id2 = this%budterm(idx)%get_id2(i) @@ -427,7 +427,7 @@ subroutine write_flowtable(this, dis, kstp, kper, cellidstr) qinflow = DZERO qoutflow = DZERO ! - ! -- determine the index, flowtype and length of + ! -- determine the index, flowtype and length of ! the flowterm idx = this%iflowterms(j) flowtype = this%budterm(idx)%get_flowtype() @@ -438,7 +438,7 @@ subroutine write_flowtable(this, dis, kstp, kper, cellidstr) colterm: do i = this%istart(j), nlist id1 = this%budterm(idx)%get_id1(i) if (this%budterm(idx)%ordered_id1) then - if(id1 > icv) then + if (id1 > icv) then this%istart(j) = i exit colterm end if @@ -497,11 +497,11 @@ subroutine write_budtable(this, kstp, kper, iout, ibudfl, totim) ! -- modules ! -- dummy class(BudgetObjectType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ibudfl - real(DP),intent(in) :: totim + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: ibudfl + real(DP), intent(in) :: totim ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -514,7 +514,7 @@ subroutine write_budtable(this, kstp, kper, iout, ibudfl, totim) ! -- return return end subroutine write_budtable - + subroutine save_flows(this, dis, ibinun, kstp, kper, delt, & pertim, totim, iout) ! ****************************************************************************** @@ -547,7 +547,7 @@ subroutine save_flows(this, dis, ibinun, kstp, kper, delt, & ! -- return return end subroutine save_flows - + subroutine read_flows(this, dis, ibinun) ! ****************************************************************************** ! read_flows -- Read froms from a binary file into this BudgetObjectType @@ -579,7 +579,7 @@ subroutine read_flows(this, dis, ibinun) ! -- return return end subroutine read_flows - + subroutine budgetobject_da(this) ! ****************************************************************************** ! budgetobject_da -- deallocate @@ -601,27 +601,27 @@ subroutine budgetobject_da(this) ! ! -- destroy the flow table if (associated(this%flowtab)) then - deallocate(this%add_cellids) - deallocate(this%icellid) - deallocate(this%nflowterms) - deallocate(this%istart) - deallocate(this%iflowterms) + deallocate (this%add_cellids) + deallocate (this%icellid) + deallocate (this%nflowterms) + deallocate (this%istart) + deallocate (this%iflowterms) call this%flowtab%table_da() - deallocate(this%flowtab) - nullify(this%flowtab) + deallocate (this%flowtab) + nullify (this%flowtab) end if ! ! -- destroy the budget object table if (associated(this%budtable)) then call this%budtable%budget_da() - deallocate(this%budtable) - nullify(this%budtable) + deallocate (this%budtable) + nullify (this%budtable) end if ! ! -- Return return end subroutine budgetobject_da - + subroutine budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2) ! ****************************************************************************** ! budgetobject_cr_bfr -- Create a new budget object from a binary flow file @@ -681,7 +681,7 @@ subroutine budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2) ! -- Return return end subroutine budgetobject_cr_bfr - + subroutine bfr_init(this, ibinun, ncv, nbudterm, iout) ! ****************************************************************************** ! bfr_init -- initialize the budget file reader @@ -700,14 +700,14 @@ subroutine bfr_init(this, ibinun, ncv, nbudterm, iout) ! ------------------------------------------------------------------------------ ! ! -- initialize budget file reader - allocate(this%bfr) + allocate (this%bfr) call this%bfr%initialize(ibinun, iout, ncv) nbudterm = this%bfr%nbudterms ! ! -- Return return end subroutine bfr_init - + subroutine bfr_advance(this, dis, iout) ! ****************************************************************************** ! bfr_advance -- copy the information from the binary file into budterms @@ -723,10 +723,10 @@ subroutine bfr_advance(this, dis, iout) integer(I4B), intent(in) :: iout ! -- dummy logical :: readnext - character(len=*), parameter :: fmtkstpkper = & - "(1x,/1x, a, ' READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" + character(len=*), parameter :: fmtkstpkper = & + &"(1x,/1x, a, ' READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" character(len=*), parameter :: fmtbudkstpkper = & - "(1x,/1x, a, ' SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & + "(1x,/1x, a, ' SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & &i0, ' TO BUDGET FILE TERMS FROM KSTP ', i0, ' AND KPER ', i0)" ! ------------------------------------------------------------------------------ ! @@ -743,28 +743,28 @@ subroutine bfr_advance(this, dis, iout) else if (this%bfr%kpernext == kper + 1 .and. this%bfr%kstpnext == 1) & readnext = .false. - endif - endif + end if + end if ! ! -- Read the next record if (readnext) then ! ! -- Write the current time step and stress period if (iout > 0) & - write(iout, fmtkstpkper) this%name, kstp, kper + write (iout, fmtkstpkper) this%name, kstp, kper ! ! -- read flows from the binary file and copy them into this%budterm(:) call this%fill_from_bfr(dis, iout) else if (iout > 0) & - write(iout, fmtbudkstpkper) trim(this%name), kstp, kper, & - this%bfr%kstp, this%bfr%kper - endif + write (iout, fmtbudkstpkper) trim(this%name), kstp, kper, & + this%bfr%kstp, this%bfr%kper + end if ! ! -- Return return end subroutine bfr_advance - + subroutine fill_from_bfr(this, dis, iout) ! ****************************************************************************** ! fill_from_bfr -- copy the information from the binary file into budterms @@ -791,5 +791,5 @@ subroutine fill_from_bfr(this, dis, iout) ! -- Return return end subroutine fill_from_bfr - -end module BudgetObjectModule \ No newline at end of file + +end module BudgetObjectModule diff --git a/src/Utilities/BudgetTerm.f90 b/src/Utilities/BudgetTerm.f90 index 79ca70697fd..e3aeb13a67a 100644 --- a/src/Utilities/BudgetTerm.f90 +++ b/src/Utilities/BudgetTerm.f90 @@ -1,6 +1,6 @@ ! A budget term is the information needed to describe flow. -! The budget object contains an array of budget terms. -! For an advanced package. The budget object describes all of +! The budget object contains an array of budget terms. +! For an advanced package. The budget object describes all of ! the flows. module BudgetTermModule @@ -12,29 +12,29 @@ module BudgetTermModule implicit none public :: BudgetTermType - + type :: BudgetTermType - - character(len=LENBUDTXT) :: flowtype ! type of flow (WEL, DRN, ...) - character(len=LENBUDTXT) :: text1id1 ! model - character(len=LENBUDTXT) :: text2id1 ! to model - character(len=LENBUDTXT) :: text1id2 ! package/model - character(len=LENBUDTXT) :: text2id2 ! to package/model - character(len=LENBUDTXT), dimension(:), pointer :: auxtxt => null() ! name of auxiliary variables - integer(I4B) :: maxlist ! allocated size of arrays - integer(I4B) :: naux ! number of auxiliary variables - integer(I4B) :: nlist ! size of arrays for this period - logical :: olconv1 = .false. ! convert id1 to user node upon output - logical :: olconv2 = .false. ! convert id2 to user node upon output - logical :: ordered_id1 ! the id1 array is ordered sequentially - integer(I4B), dimension(:), pointer :: id1 => null() ! first id (maxlist) - integer(I4B), dimension(:), pointer :: id2 => null() ! second id (maxlist) - real(DP), dimension(:), pointer :: flow => null() ! point this to simvals or simtomvr (maxlist) - real(DP), dimension(:, :), pointer :: auxvar => null() ! auxiliary variables (naux, maxlist) - integer(I4B) :: icounter ! counter variable - + + character(len=LENBUDTXT) :: flowtype ! type of flow (WEL, DRN, ...) + character(len=LENBUDTXT) :: text1id1 ! model + character(len=LENBUDTXT) :: text2id1 ! to model + character(len=LENBUDTXT) :: text1id2 ! package/model + character(len=LENBUDTXT) :: text2id2 ! to package/model + character(len=LENBUDTXT), dimension(:), pointer :: auxtxt => null() ! name of auxiliary variables + integer(I4B) :: maxlist ! allocated size of arrays + integer(I4B) :: naux ! number of auxiliary variables + integer(I4B) :: nlist ! size of arrays for this period + logical :: olconv1 = .false. ! convert id1 to user node upon output + logical :: olconv2 = .false. ! convert id2 to user node upon output + logical :: ordered_id1 ! the id1 array is ordered sequentially + integer(I4B), dimension(:), pointer :: id1 => null() ! first id (maxlist) + integer(I4B), dimension(:), pointer :: id2 => null() ! second id (maxlist) + real(DP), dimension(:), pointer :: flow => null() ! point this to simvals or simtomvr (maxlist) + real(DP), dimension(:, :), pointer :: auxvar => null() ! auxiliary variables (naux, maxlist) + integer(I4B) :: icounter ! counter variable + contains - + procedure :: initialize procedure :: allocate_arrays procedure :: reset @@ -49,11 +49,11 @@ module BudgetTermModule procedure :: read_flows procedure :: fill_from_bfr procedure :: deallocate_arrays - + end type BudgetTermType - contains - +contains + subroutine initialize(this, flowtype, text1id1, text2id1, & text1id2, text2id2, maxlist, olconv1, olconv2, & naux, auxtxt, ordered_id1) @@ -94,7 +94,7 @@ subroutine initialize(this, flowtype, text1id1, text2id1, & this%ordered_id1 = .true. if (present(ordered_id1)) this%ordered_id1 = ordered_id1 end subroutine initialize - + subroutine allocate_arrays(this) ! ****************************************************************************** ! allocate_arrays -- allocate budget term arrays @@ -106,13 +106,13 @@ subroutine allocate_arrays(this) ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - allocate(this%auxtxt(this%naux)) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) + allocate (this%auxtxt(this%naux)) end subroutine allocate_arrays - + subroutine deallocate_arrays(this) ! ****************************************************************************** ! deallocate_arrays -- deallocate budget term arrays @@ -124,13 +124,13 @@ subroutine deallocate_arrays(this) ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - deallocate(this%auxtxt) + deallocate (this%id1) + deallocate (this%id2) + deallocate (this%flow) + deallocate (this%auxvar) + deallocate (this%auxtxt) end subroutine deallocate_arrays - + subroutine reset(this, nlist) ! ****************************************************************************** ! reset -- reset the budget term and counter so terms can be updated @@ -146,10 +146,10 @@ subroutine reset(this, nlist) this%nlist = nlist this%icounter = 1 end subroutine reset - + subroutine update_term(this, id1, id2, flow, auxvar) ! ****************************************************************************** -! update_term -- replace the terms in position this%icounter +! update_term -- replace the terms in position this%icounter ! for id1, id2, flow, and aux ! ****************************************************************************** ! @@ -169,7 +169,7 @@ subroutine update_term(this, id1, id2, flow, auxvar) if (present(auxvar)) this%auxvar(:, this%icounter) = auxvar(1:this%naux) this%icounter = this%icounter + 1 end subroutine update_term - + subroutine accumulate_flow(this, ratin, ratout) ! ****************************************************************************** ! accumulate_flow -- calculate ratin and ratout for all the flow terms @@ -197,7 +197,7 @@ subroutine accumulate_flow(this, ratin, ratout) end if end do end subroutine accumulate_flow - + subroutine save_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim, & iout) ! ****************************************************************************** @@ -254,7 +254,7 @@ subroutine save_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim, & olconv2=this%olconv2) end do end subroutine save_flows - + function get_nlist(this) result(nlist) ! ****************************************************************************** ! get_nlist -- get the number of entries for the stress period @@ -264,7 +264,7 @@ function get_nlist(this) result(nlist) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - integer(I4B) :: nlist + integer(I4B) :: nlist ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ @@ -273,7 +273,7 @@ function get_nlist(this) result(nlist) ! -- return return end function get_nlist - + function get_flowtype(this) result(flowtype) ! ****************************************************************************** ! get_flowtype -- get the flowtype for the budget term @@ -283,7 +283,7 @@ function get_flowtype(this) result(flowtype) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - character(len=LENBUDTXT) :: flowtype + character(len=LENBUDTXT) :: flowtype ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ @@ -292,7 +292,7 @@ function get_flowtype(this) result(flowtype) ! -- return return end function get_flowtype - + function get_id1(this, icount) result(id1) ! ****************************************************************************** ! get_id1 -- get id1(icount) for the budget term @@ -302,7 +302,7 @@ function get_id1(this, icount) result(id1) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - integer(I4B) :: id1 + integer(I4B) :: id1 ! -- dummy class(BudgetTermType) :: this integer(I4B), intent(in) :: icount @@ -312,7 +312,7 @@ function get_id1(this, icount) result(id1) ! -- return return end function get_id1 - + function get_id2(this, icount) result(id2) ! ****************************************************************************** ! get_id2 -- get id2(icount) for the budget term @@ -322,7 +322,7 @@ function get_id2(this, icount) result(id2) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - integer(I4B) :: id2 + integer(I4B) :: id2 ! -- dummy class(BudgetTermType) :: this integer(I4B), intent(in) :: icount @@ -332,7 +332,7 @@ function get_id2(this, icount) result(id2) ! -- return return end function get_id2 - + function get_flow(this, icount) result(flow) ! ****************************************************************************** ! get_flow -- get flow(icount) for the budget term @@ -342,7 +342,7 @@ function get_flow(this, icount) result(flow) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - real(DP) :: flow + real(DP) :: flow ! -- dummy class(BudgetTermType) :: this integer(I4B), intent(in) :: icount @@ -352,7 +352,7 @@ function get_flow(this, icount) result(flow) ! -- return return end function get_flow - + subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) ! ****************************************************************************** ! read_flows -- read flows from a binary file @@ -377,48 +377,48 @@ subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) integer(I4B) :: n2 real(DP) :: q ! ------------------------------------------------------------------------------ - read(ibinun) kstp, kper, this%flowtype, this%nlist, idum1, idum2 - read(ibinun) imeth, delt, pertim, totim - read(ibinun) this%text1id1 - read(ibinun) this%text2id1 - read(ibinun) this%text1id2 - read(ibinun) this%text2id2 - read(ibinun) this%naux + read (ibinun) kstp, kper, this%flowtype, this%nlist, idum1, idum2 + read (ibinun) imeth, delt, pertim, totim + read (ibinun) this%text1id1 + read (ibinun) this%text2id1 + read (ibinun) this%text1id2 + read (ibinun) this%text2id2 + read (ibinun) this%naux this%naux = this%naux - 1 if (.not. associated(this%auxtxt)) then - allocate(this%auxtxt(this%naux)) + allocate (this%auxtxt(this%naux)) else if (size(this%auxtxt) /= this%naux) then - deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) + deallocate (this%auxtxt) + allocate (this%auxtxt(this%naux)) end if end if - if (this%naux > 0) read(ibinun) (this%auxtxt(j), j = 1, this%naux) - read(ibinun) this%nlist + if (this%naux > 0) read (ibinun) (this%auxtxt(j), j=1, this%naux) + read (ibinun) this%nlist if (.not. associated(this%id1)) then this%maxlist = this%nlist - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) else if (this%nlist > this%maxlist) then this%maxlist = this%nlist - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + deallocate (this%id1) + deallocate (this%id2) + deallocate (this%flow) + deallocate (this%auxvar) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) end if end if do i = 1, this%nlist - read(ibinun) n1 - read(ibinun) n2 - read(ibinun) q - read(ibinun) (this%auxvar(j, i), j = 1, this%naux) + read (ibinun) n1 + read (ibinun) n2 + read (ibinun) q + read (ibinun) (this%auxvar(j, i), j=1, this%naux) if (this%olconv1) n1 = dis%get_nodenumber(n1, 0) if (this%olconv2) n2 = dis%get_nodenumber(n2, 0) this%id1(i) = n1 @@ -426,7 +426,7 @@ subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) this%flow(i) = q end do end subroutine read_flows - + subroutine fill_from_bfr(this, bfr, dis) ! ****************************************************************************** ! fill_from_bfr -- copy the flow from the binary file reader into this budterm @@ -453,32 +453,32 @@ subroutine fill_from_bfr(this, bfr, dis) this%text2id2 = bfr%dstpackagename this%naux = bfr%naux if (.not. associated(this%auxtxt)) then - allocate(this%auxtxt(this%naux)) + allocate (this%auxtxt(this%naux)) else if (size(this%auxtxt) /= this%naux) then - deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) + deallocate (this%auxtxt) + allocate (this%auxtxt(this%naux)) end if end if if (this%naux > 0) this%auxtxt(:) = bfr%auxtxt(:) this%nlist = bfr%nlist if (.not. associated(this%id1)) then this%maxlist = this%nlist - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) else if (this%nlist > this%maxlist) then this%maxlist = this%nlist - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + deallocate (this%id1) + deallocate (this%id2) + deallocate (this%flow) + deallocate (this%auxvar) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) end if end if do i = 1, this%nlist @@ -493,5 +493,5 @@ subroutine fill_from_bfr(this, bfr, dis) this%flow(i) = q end do end subroutine fill_from_bfr - -end module BudgetTermModule \ No newline at end of file + +end module BudgetTermModule diff --git a/src/Utilities/Constants.f90 b/src/Utilities/Constants.f90 index 830f1ae8c92..b23a28e129c 100644 --- a/src/Utilities/Constants.f90 +++ b/src/Utilities/Constants.f90 @@ -10,172 +10,172 @@ module ConstantsModule use KindModule public ! -- constants - integer(I4B), parameter :: IUSERFORMATSTRIP = -99 !< default user format strip - integer(I4B), parameter :: IUSERFORMATWRAP = 99 !< default user format wrap - integer(I4B), parameter :: LENBIGLINE = 5000 !< maximum length of a big line - integer(I4B), parameter :: LENHUGELINE = 50000 !< maximum length of a huge line - integer(I4B), parameter :: LENVARNAME = 16 !< maximum length of a variable name - integer(I4B), parameter :: LENCOMPONENTNAME = 16 !< maximum length of a component name - integer(I4B), parameter :: LENSOLUTIONNAME = LENCOMPONENTNAME !< maximum length of the solution name - integer(I4B), parameter :: LENMODELNAME = LENCOMPONENTNAME !< maximum length of the model name - integer(I4B), parameter :: LENPACKAGENAME = LENCOMPONENTNAME !< maximum length of the package name - integer(I4B), parameter :: LENEXCHANGENAME = LENCOMPONENTNAME !< maximum length of the exchange name - integer(I4B), parameter :: LENBUDROWLABEL = 2 * LENPACKAGENAME + 1 !< maximum length of the rowlabel string used in the budget table - integer(I4B), parameter :: LENMEMSEPARATOR = 1 !< maximum length of the memory path separator used, currently a '/' + integer(I4B), parameter :: IUSERFORMATSTRIP = -99 !< default user format strip + integer(I4B), parameter :: IUSERFORMATWRAP = 99 !< default user format wrap + integer(I4B), parameter :: LENBIGLINE = 5000 !< maximum length of a big line + integer(I4B), parameter :: LENHUGELINE = 50000 !< maximum length of a huge line + integer(I4B), parameter :: LENVARNAME = 16 !< maximum length of a variable name + integer(I4B), parameter :: LENCOMPONENTNAME = 16 !< maximum length of a component name + integer(I4B), parameter :: LENSOLUTIONNAME = LENCOMPONENTNAME !< maximum length of the solution name + integer(I4B), parameter :: LENMODELNAME = LENCOMPONENTNAME !< maximum length of the model name + integer(I4B), parameter :: LENPACKAGENAME = LENCOMPONENTNAME !< maximum length of the package name + integer(I4B), parameter :: LENEXCHANGENAME = LENCOMPONENTNAME !< maximum length of the exchange name + integer(I4B), parameter :: LENBUDROWLABEL = 2 * LENPACKAGENAME + 1 !< maximum length of the rowlabel string used in the budget table + integer(I4B), parameter :: LENMEMSEPARATOR = 1 !< maximum length of the memory path separator used, currently a '/' integer(I4B), parameter :: LENMEMPATH = & 2 * LENCOMPONENTNAME + & - LENMEMSEPARATOR !< maximum length of the memory path + LENMEMSEPARATOR !< maximum length of the memory path integer(I4B), parameter :: LENMEMADDRESS = & LENMEMPATH + & LENMEMSEPARATOR + & - LENVARNAME !< maximum length of the full memory address, including variable name - integer(I4B), parameter :: LENAUXNAME = 16 !< maximum length of a aux variable - integer(I4B), parameter :: LENBOUNDNAME = 40 !< maximum length of a bound name - integer(I4B), parameter :: LENBUDTXT = 16 !< maximum length of a budget component names - integer(I4B), parameter :: LENPACKAGETYPE = 7 !< maximum length of a package type (DIS6, SFR6, CSUB6, etc.) - integer(I4B), parameter :: LENFTYPE = 5 !< maximum length of a package type (DIS, WEL, OC, etc.) - integer(I4B), parameter :: LENOBSNAME = 40 !< maximum length of a observation name - integer(I4B), parameter :: LENOBSTYPE = 30 !< maximum length of a observation type (CONTINUOUS) - integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME !< maximum length of a time series name - integer(I4B), parameter :: LENTIMESERIESTEXT = 16 !< maximum length of a time series text - integer(I4B), parameter :: LENDATETIME = 30 !< maximum length of a date time string - integer(I4B), parameter :: LINELENGTH = 300 !< maximum length of a standard line - integer(I4B), parameter :: LENLISTLABEL = 500 !< maximum length of a llist label - integer(I4B), parameter :: MAXCHARLEN = max(1000, LENBIGLINE) !< maximum length of char string - integer(I4B), parameter :: MAXOBSTYPES = 100 !< maximum number of observation types - integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 !< named bound flag - integer(I4B), parameter :: LENPAKLOC = 34 !< maximum length of a package location - integer(I4B), parameter :: IZERO = 0 !< integer constant zero + LENVARNAME !< maximum length of the full memory address, including variable name + integer(I4B), parameter :: LENAUXNAME = 16 !< maximum length of a aux variable + integer(I4B), parameter :: LENBOUNDNAME = 40 !< maximum length of a bound name + integer(I4B), parameter :: LENBUDTXT = 16 !< maximum length of a budget component names + integer(I4B), parameter :: LENPACKAGETYPE = 7 !< maximum length of a package type (DIS6, SFR6, CSUB6, etc.) + integer(I4B), parameter :: LENFTYPE = 5 !< maximum length of a package type (DIS, WEL, OC, etc.) + integer(I4B), parameter :: LENOBSNAME = 40 !< maximum length of a observation name + integer(I4B), parameter :: LENOBSTYPE = 30 !< maximum length of a observation type (CONTINUOUS) + integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME !< maximum length of a time series name + integer(I4B), parameter :: LENTIMESERIESTEXT = 16 !< maximum length of a time series text + integer(I4B), parameter :: LENDATETIME = 30 !< maximum length of a date time string + integer(I4B), parameter :: LINELENGTH = 300 !< maximum length of a standard line + integer(I4B), parameter :: LENLISTLABEL = 500 !< maximum length of a llist label + integer(I4B), parameter :: MAXCHARLEN = max(1000, LENBIGLINE) !< maximum length of char string + integer(I4B), parameter :: MAXOBSTYPES = 100 !< maximum number of observation types + integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 !< named bound flag + integer(I4B), parameter :: LENPAKLOC = 34 !< maximum length of a package location + integer(I4B), parameter :: IZERO = 0 !< integer constant zero ! ! -- file constants - integer(I4B), parameter :: IUOC = 999 !< open/close file unit number - integer(I4B), parameter :: IUSTART = 1000 !< starting file unit number - integer(I4B), parameter :: IULAST = 10000 !< maximum file unit number (this allows for 9000 open files) + integer(I4B), parameter :: IUOC = 999 !< open/close file unit number + integer(I4B), parameter :: IUSTART = 1000 !< starting file unit number + integer(I4B), parameter :: IULAST = 10000 !< maximum file unit number (this allows for 9000 open files) ! ! -- memory manager constants - integer(I4B), public, parameter :: MAXMEMRANK = 3 !< maximum memory manager length (up to 3-dimensional arrays) - integer(I4B), public, parameter :: LENMEMTYPE = 50 !< maximum length of a memory manager type + integer(I4B), public, parameter :: MAXMEMRANK = 3 !< maximum memory manager length (up to 3-dimensional arrays) + integer(I4B), public, parameter :: LENMEMTYPE = 50 !< maximum length of a memory manager type ! ! -- real constants - real(DP), parameter :: DZERO = 0.0_DP !< real constant zero - real(DP), parameter :: DQUARTER = 0.25_DP !< real constant 1/3 - real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP !< real constant 1/3 - real(DP), parameter :: DHALF = 0.5_DP !< real constant 1/2 - real(DP), parameter :: DP6 = 0.6_DP !< real constant 3/5 - real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP !< real constant 2/3 - real(DP), parameter :: DP7 = 0.7_DP !< real constant 7/10 - real(DP), parameter :: DP9 = 0.9_DP !< real constant 9/10 - real(DP), parameter :: DP99 = 0.99_DP !< real constant 99/100 - real(DP), parameter :: DP999 = 0.999_DP !< real constant 999/1000 - - real(DP), parameter :: DONE = 1.0_DP !< real constant 1 - real(DP), parameter :: D1P1 = 1.1_DP !< real constant 1.1 - real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP !< real constant 5/3 - real(DP), parameter :: DTWO = 2.0_DP !< real constant 2 - real(DP), parameter :: DTHREE = 3.0_DP !< real constant 3 - real(DP), parameter :: DFOUR = 4.0_DP !< real constant 4 - real(DP), parameter :: DSIX = 6.0_DP !< real constant 6 - real(DP), parameter :: DEIGHT = 8.0_DP !< real constant 8 - real(DP), parameter :: DTEN = 1.0e1_DP !< real constant 10 - real(DP), parameter :: DHUNDRED = 1.0e2_DP !< real constant 100 - - real(DP), parameter :: DEP3 = 1.0e3_DP !< real constant 1000 - real(DP), parameter :: DEP6 = 1.0e6_DP !< real constant 1000000 - real(DP), parameter :: DEP9 = 1.0e9_DP !< real constant 1e9 - real(DP), parameter :: DEP20 = 1.0e20_DP !< real constant 1e20 - - real(DP), parameter :: DHNOFLO = 1.e30_DP !< real no flow constant - real(DP), parameter :: DHDRY = -1.e30_DP !< real dry cell constant - real(DP), parameter :: DNODATA = 3.0e30_DP !< real no data constant - - real(DP), parameter :: DEM1 = 1.0e-1_DP !< real constant 1e-1 - real(DP), parameter :: D5EM2 = 5.0e-2_DP !< real constant 5e-2 - real(DP), parameter :: DEM2 = 1.0e-2_DP !< real constant 1e-2 - real(DP), parameter :: DEM3 = 1.0e-3_DP !< real constant 1e-3 - real(DP), parameter :: DEM4 = 1.0e-4_DP !< real constant 1e-4 - real(DP), parameter :: DEM5 = 1.0e-5_DP !< real constant 1e-5 - real(DP), parameter :: DEM6 = 1.0e-6_DP !< real constant 1e-6 - real(DP), parameter :: DEM7 = 1.0e-7_DP !< real constant 1e-7 - real(DP), parameter :: DEM8 = 1.0e-8_DP !< real constant 1e-8 - real(DP), parameter :: DEM9 = 1.0e-9_DP !< real constant 1e-9 - real(DP), parameter :: DEM10 = 1.0e-10_DP !< real constant 1e-10 - real(DP), parameter :: DEM12 = 1.0e-12_DP !< real constant 1e-12 - real(DP), parameter :: DEM14 = 1.0e-14_DP !< real constant 1e-14 - real(DP), parameter :: DEM15 = 1.0e-15_DP !< real constant 1e-15 - real(DP), parameter :: DEM20 = 1.0e-20_DP !< real constant 1e-20 - real(DP), parameter :: DEM30 = 1.0e-30_DP !< real constant 1e-30 - - real(DP), parameter :: DPREC = EPSILON(1.0_DP) !< real constant machine precision - real(DP), parameter :: DSAME = DHUNDRED * DPREC !< real constant for values that are considered - !! the same based on machine precision - - real(DP), parameter :: DLNLOW = 0.995_DP !< real constant low ratio used to calculate log mean of K - real(DP), parameter :: DLNHIGH = 1.005_DP !< real constant high ratio used to calculate log mean of K - - real(DP), parameter :: DPI = DFOUR * ATAN(DONE) !< real constant \f$\pi\f$ - real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE) !< real constant \f$2 \pi\f$ - real(DP), parameter :: DPIO180 = datan(DONE) / 4.5d1 !< real constant \f$\pi/180\f$ - - real(DP), parameter :: DGRAVITY = 9.80665_DP !< real constant gravitational acceleration (m/(s s)) - real(DP), parameter :: DCD = 0.61_DP !< real constant weir coefficient in SI units + real(DP), parameter :: DZERO = 0.0_DP !< real constant zero + real(DP), parameter :: DQUARTER = 0.25_DP !< real constant 1/3 + real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP !< real constant 1/3 + real(DP), parameter :: DHALF = 0.5_DP !< real constant 1/2 + real(DP), parameter :: DP6 = 0.6_DP !< real constant 3/5 + real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP !< real constant 2/3 + real(DP), parameter :: DP7 = 0.7_DP !< real constant 7/10 + real(DP), parameter :: DP9 = 0.9_DP !< real constant 9/10 + real(DP), parameter :: DP99 = 0.99_DP !< real constant 99/100 + real(DP), parameter :: DP999 = 0.999_DP !< real constant 999/1000 + + real(DP), parameter :: DONE = 1.0_DP !< real constant 1 + real(DP), parameter :: D1P1 = 1.1_DP !< real constant 1.1 + real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP !< real constant 5/3 + real(DP), parameter :: DTWO = 2.0_DP !< real constant 2 + real(DP), parameter :: DTHREE = 3.0_DP !< real constant 3 + real(DP), parameter :: DFOUR = 4.0_DP !< real constant 4 + real(DP), parameter :: DSIX = 6.0_DP !< real constant 6 + real(DP), parameter :: DEIGHT = 8.0_DP !< real constant 8 + real(DP), parameter :: DTEN = 1.0e1_DP !< real constant 10 + real(DP), parameter :: DHUNDRED = 1.0e2_DP !< real constant 100 + + real(DP), parameter :: DEP3 = 1.0e3_DP !< real constant 1000 + real(DP), parameter :: DEP6 = 1.0e6_DP !< real constant 1000000 + real(DP), parameter :: DEP9 = 1.0e9_DP !< real constant 1e9 + real(DP), parameter :: DEP20 = 1.0e20_DP !< real constant 1e20 + + real(DP), parameter :: DHNOFLO = 1.e30_DP !< real no flow constant + real(DP), parameter :: DHDRY = -1.e30_DP !< real dry cell constant + real(DP), parameter :: DNODATA = 3.0e30_DP !< real no data constant + + real(DP), parameter :: DEM1 = 1.0e-1_DP !< real constant 1e-1 + real(DP), parameter :: D5EM2 = 5.0e-2_DP !< real constant 5e-2 + real(DP), parameter :: DEM2 = 1.0e-2_DP !< real constant 1e-2 + real(DP), parameter :: DEM3 = 1.0e-3_DP !< real constant 1e-3 + real(DP), parameter :: DEM4 = 1.0e-4_DP !< real constant 1e-4 + real(DP), parameter :: DEM5 = 1.0e-5_DP !< real constant 1e-5 + real(DP), parameter :: DEM6 = 1.0e-6_DP !< real constant 1e-6 + real(DP), parameter :: DEM7 = 1.0e-7_DP !< real constant 1e-7 + real(DP), parameter :: DEM8 = 1.0e-8_DP !< real constant 1e-8 + real(DP), parameter :: DEM9 = 1.0e-9_DP !< real constant 1e-9 + real(DP), parameter :: DEM10 = 1.0e-10_DP !< real constant 1e-10 + real(DP), parameter :: DEM12 = 1.0e-12_DP !< real constant 1e-12 + real(DP), parameter :: DEM14 = 1.0e-14_DP !< real constant 1e-14 + real(DP), parameter :: DEM15 = 1.0e-15_DP !< real constant 1e-15 + real(DP), parameter :: DEM20 = 1.0e-20_DP !< real constant 1e-20 + real(DP), parameter :: DEM30 = 1.0e-30_DP !< real constant 1e-30 + + real(DP), parameter :: DPREC = EPSILON(1.0_DP) !< real constant machine precision + real(DP), parameter :: DSAME = DHUNDRED * DPREC !< real constant for values that are considered + !! the same based on machine precision + + real(DP), parameter :: DLNLOW = 0.995_DP !< real constant low ratio used to calculate log mean of K + real(DP), parameter :: DLNHIGH = 1.005_DP !< real constant high ratio used to calculate log mean of K + + real(DP), parameter :: DPI = DFOUR * ATAN(DONE) !< real constant \f$\pi\f$ + real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE) !< real constant \f$2 \pi\f$ + real(DP), parameter :: DPIO180 = datan(DONE) / 4.5d1 !< real constant \f$\pi/180\f$ + + real(DP), parameter :: DGRAVITY = 9.80665_DP !< real constant gravitational acceleration (m/(s s)) + real(DP), parameter :: DCD = 0.61_DP !< real constant weir coefficient in SI units character(len=10), dimension(3, 3), parameter :: & cidxnames = reshape( & [' NODE', ' ', ' ', & ' LAYER', ' CELL2D', ' ', & - ' LAYER', ' ROW', ' COL'], [3, 3]) !< cellid labels for DIS, DISV, and DISU discretizations + ' LAYER', ' ROW', ' COL'], [3, 3]) !< cellid labels for DIS, DISV, and DISU discretizations ! -- enumerator used with TimeSeriesType ENUM, BIND(C) - ENUMERATOR :: UNDEFINED = 0 !< 0 - ENUMERATOR :: STEPWISE = 1 !< 1 - ENUMERATOR :: LINEAR = 2 !< 2 - ENUMERATOR :: LINEAREND = 3 !< 3 + ENUMERATOR :: UNDEFINED = 0 !< 0 + ENUMERATOR :: STEPWISE = 1 !< 1 + ENUMERATOR :: LINEAR = 2 !< 2 + ENUMERATOR :: LINEAREND = 3 !< 3 END ENUM ! -- enumerator used with table objects ENUM, BIND(C) - ENUMERATOR :: TABLEFT = 0 !< 0 - ENUMERATOR :: TABCENTER = 1 !< 1 - ENUMERATOR :: TABRIGHT = 2 !< 2 + ENUMERATOR :: TABLEFT = 0 !< 0 + ENUMERATOR :: TABCENTER = 1 !< 1 + ENUMERATOR :: TABRIGHT = 2 !< 2 END ENUM ! -- enumerator used to define table column data type ENUM, BIND(C) - ENUMERATOR :: TABSTRING = 0 !< 0 - ENUMERATOR :: TABUCSTRING = 1 !< 1 - ENUMERATOR :: TABINTEGER = 2 !< 2 - ENUMERATOR :: TABREAL = 3 !< 3 + ENUMERATOR :: TABSTRING = 0 !< 0 + ENUMERATOR :: TABUCSTRING = 1 !< 1 + ENUMERATOR :: TABINTEGER = 2 !< 2 + ENUMERATOR :: TABREAL = 3 !< 3 END ENUM ! -- enumerator used to define output option ENUM, BIND(C) - ENUMERATOR :: VSUMMARY = 0 !< 0 - ENUMERATOR :: VALL = 1 !< 1 - ENUMERATOR :: VDEBUG = 2 !< 2 + ENUMERATOR :: VSUMMARY = 0 !< 0 + ENUMERATOR :: VALL = 1 !< 1 + ENUMERATOR :: VDEBUG = 2 !< 2 END ENUM ! -- enumerator that defines the operating system ENUM, BIND(C) - ENUMERATOR :: OSUNDEF = 0 !< 0 - ENUMERATOR :: OSLINUX = 1 !< 1 - ENUMERATOR :: OSMAC = 2 !< 2 - ENUMERATOR :: OSWIN = 3 !< 3 + ENUMERATOR :: OSUNDEF = 0 !< 0 + ENUMERATOR :: OSLINUX = 1 !< 1 + ENUMERATOR :: OSMAC = 2 !< 2 + ENUMERATOR :: OSWIN = 3 !< 3 END ENUM ! -- enumerator that defines the simulation mode ENUM, BIND(C) ENUMERATOR :: MVALIDATE = 0 !< 0 - ENUMERATOR :: MNORMAL = 1 !< 1 - ENUMERATOR :: MRUN = 2 !< 2 + ENUMERATOR :: MNORMAL = 1 !< 1 + ENUMERATOR :: MRUN = 2 !< 2 END ENUM ! -- enumerator that defines the compiler ENUM, BIND(C) - ENUMERATOR :: CUNKNOWN = 0 !< 0 + ENUMERATOR :: CUNKNOWN = 0 !< 0 ENUMERATOR :: CGFORTRAN = 1 !< 1 - ENUMERATOR :: CINTEL = 3 !< 2 - ENUMERATOR :: CCRAYFTN = 3 !< 3 + ENUMERATOR :: CINTEL = 3 !< 2 + ENUMERATOR :: CCRAYFTN = 3 !< 3 END ENUM end module ConstantsModule diff --git a/src/Utilities/HashTable.f90 b/src/Utilities/HashTable.f90 index 5e37abf94e5..51f90b04efd 100644 --- a/src/Utilities/HashTable.f90 +++ b/src/Utilities/HashTable.f90 @@ -1,5 +1,5 @@ ! HashTableType implements a hash table for storing integers, -! for use as an index for an array that could contain +! for use as an index for an array that could contain ! any data type. This HashTableModule was designed using the ! dictionary implementation by Arjen Markus of the Flibs ! collection of Fortran utilities. This hash table works @@ -7,37 +7,37 @@ ! strings and each string will be assigned a unique number ! between 1 and n, allowing an efficient way to store a ! unique integer index with a character string. - + module HashTableModule use KindModule, only: DP, I4B - + implicit none private public HashTableType public hash_table_cr public hash_table_da - - integer, parameter, private :: HASH_SIZE = 4993 + + integer, parameter, private :: HASH_SIZE = 4993 integer, parameter, private :: MULTIPLIER = 31 type :: ListDataType character(len=:), allocatable :: key integer(I4B) :: index end type ListDataType - + type :: ListType type(ListDataType) :: listdata type(ListType), pointer :: next => null() contains procedure :: add => listtype_add end type ListType - + type :: HashListType type(ListType), pointer :: list => null() end type HashListType - + type :: HashTableType private type(HashListType), dimension(:), pointer :: table => null() @@ -46,9 +46,9 @@ module HashTableModule procedure :: get_elem procedure :: get_index end type HashTableType - - contains - + +contains + subroutine hash_table_cr(ht) ! ****************************************************************************** ! hash_table_cr -- public subroutine to create the hash table object @@ -63,18 +63,18 @@ subroutine hash_table_cr(ht) ! ------------------------------------------------------------------------------ ! ! -- allocate - allocate(ht) - allocate(ht%table(HASH_SIZE)) + allocate (ht) + allocate (ht%table(HASH_SIZE)) ! ! -- nullify each list do i = 1, HASH_SIZE ht%table(i)%list => null() - enddo + end do ! ! -- return return end subroutine hash_table_cr - + subroutine hash_table_da(ht) ! ****************************************************************************** ! hash_table_da -- public subroutine to deallocate the hash table object @@ -90,19 +90,19 @@ subroutine hash_table_da(ht) ! ! -- deallocate the list for each hash do i = 1, size(ht%table) - if ( associated( ht%table(i)%list)) then + if (associated(ht%table(i)%list)) then call listtype_da(ht%table(i)%list) - endif - enddo + end if + end do ! ! -- deallocate the table and the hash table - deallocate(ht%table) - deallocate(ht) + deallocate (ht%table) + deallocate (ht) ! ! -- return return end subroutine hash_table_da - + subroutine add_entry(this, key, index) ! ****************************************************************************** ! add_entry -- hash table method to add a key/index entry @@ -157,16 +157,16 @@ function get_elem(this, key) result(elem) elem => this%table(ihash)%list do while (associated(elem)) if (elem%listdata%key == key) then - exit + exit else elem => elem%next end if - enddo + end do ! ! -- return return - end function get_elem - + end function get_elem + function get_index(this, key) result(index) ! ****************************************************************************** ! get_index -- get the integer index that corresponds to this hash. @@ -188,12 +188,12 @@ function get_index(this, key) result(index) index = elem%listdata%index else index = 0 - endif + end if ! ! -- return return end function get_index - + subroutine listtype_cr(list, key, index) ! ****************************************************************************** ! listtype_cr -- subroutine to create a list @@ -206,7 +206,7 @@ subroutine listtype_cr(list, key, index) character(len=*), intent(in) :: key integer(I4B), intent(in) :: index ! ------------------------------------------------------------------------------ - allocate(list) + allocate (list) list%next => null() list%listdata%key = key list%listdata%index = index @@ -229,7 +229,7 @@ subroutine listtype_add(this, key, index) ! -- local type(ListType), pointer :: next ! ------------------------------------------------------------------------------ - allocate(next) + allocate (next) next%listdata%key = key next%listdata%index = index next%next => this%next @@ -249,15 +249,15 @@ subroutine listtype_da(list) ! -- dummy type(ListType), pointer, intent(in) :: list ! -- local - type(ListType), pointer :: current - type(ListType), pointer :: elem + type(ListType), pointer :: current + type(ListType), pointer :: elem ! ------------------------------------------------------------------------------ elem => list - do while ( associated(elem) ) + do while (associated(elem)) current => elem elem => current%next - deallocate(current) - enddo + deallocate (current) + end do ! ! -- return return @@ -277,9 +277,9 @@ function hashfunc(key) result(ihash) integer(I4B) :: i ! ------------------------------------------------------------------------------ ihash = 0 - do i = 1,len(key) - ihash = modulo( MULTIPLIER * ihash + ichar(key(i:i)), HASH_SIZE) - enddo + do i = 1, len(key) + ihash = modulo(MULTIPLIER * ihash + ichar(key(i:i)), HASH_SIZE) + end do ihash = 1 + modulo(ihash - 1, HASH_SIZE) ! ! -- return diff --git a/src/Utilities/HeadFileReader.f90 b/src/Utilities/HeadFileReader.f90 index 6795dc60a6d..2e2253e2c1c 100644 --- a/src/Utilities/HeadFileReader.f90 +++ b/src/Utilities/HeadFileReader.f90 @@ -4,12 +4,12 @@ module HeadFileReaderModule use ConstantsModule, only: LINELENGTH implicit none - + private public :: HeadFileReaderType - + type :: HeadFileReaderType - + integer(I4B) :: inunit character(len=16) :: text integer(I4B) :: nlay @@ -22,17 +22,17 @@ module HeadFileReaderModule real(DP) :: pertim real(DP) :: totim real(DP), dimension(:), allocatable :: head - + contains - + procedure :: initialize procedure :: read_record procedure :: finalize - + end type HeadFileReaderType - - contains - + +contains + subroutine initialize(this, iu, iout) ! ****************************************************************************** ! initialize @@ -56,27 +56,27 @@ subroutine initialize(this, iu, iout) call this%read_record(success) kstp_last = this%kstp kper_last = this%kper - rewind(this%inunit) + rewind (this%inunit) ! ! -- Determine number of records within a time step if (iout > 0) & - write(iout, '(a)') & - 'Reading binary file to determine number of records per time step.' + write (iout, '(a)') & + 'Reading binary file to determine number of records per time step.' do call this%read_record(success, iout) if (.not. success) exit if (kstp_last /= this%kstp .or. kper_last /= this%kper) exit this%nlay = this%nlay + 1 - enddo - rewind(this%inunit) + end do + rewind (this%inunit) if (iout > 0) & - write(iout, '(a, i0, a)') 'Detected ', this%nlay, & + write (iout, '(a, i0, a)') 'Detected ', this%nlay, & ' unique records in binary file.' ! ! -- return return end subroutine initialize - + subroutine read_record(this, success, iout_opt) ! ****************************************************************************** ! read_record @@ -99,48 +99,48 @@ subroutine read_record(this, success, iout_opt) iout = iout_opt else iout = 0 - endif + end if ! this%kstp = 0 this%kper = 0 success = .true. this%kstpnext = 0 this%kpernext = 0 - read(this%inunit, iostat=iostat) this%kstp, this%kper, this%pertim, & + read (this%inunit, iostat=iostat) this%kstp, this%kper, this%pertim, & this%totim, this%text, ncol, nrow, ilay if (iostat /= 0) then success = .false. if (iostat < 0) this%endoffile = .true. return - endif + end if ! ! -- allocate head to proper size if (.not. allocated(this%head)) then - allocate(this%head(ncol*nrow)) + allocate (this%head(ncol * nrow)) else - if (size(this%head) /= ncol*nrow) then - deallocate(this%head) - allocate(this%head(ncol*nrow)) - endif - endif + if (size(this%head) /= ncol * nrow) then + deallocate (this%head) + allocate (this%head(ncol * nrow)) + end if + end if ! ! -- read the head array - read(this%inunit) this%head + read (this%inunit) this%head ! ! -- look ahead to next kstp and kper, then backup if read successfully if (.not. this%endoffile) then - read(this%inunit, iostat=iostat) this%kstpnext, this%kpernext + read (this%inunit, iostat=iostat) this%kstpnext, this%kpernext if (iostat == 0) then call fseek_stream(this%inunit, -2 * I4B, 1, iostat) else if (iostat < 0) then this%endoffile = .true. - endif - endif + end if + end if ! ! -- return return end subroutine read_record - + subroutine finalize(this) ! ****************************************************************************** ! budgetdata_finalize @@ -150,11 +150,11 @@ subroutine finalize(this) ! ------------------------------------------------------------------------------ class(HeadFileReaderType) :: this ! ------------------------------------------------------------------------------ - close(this%inunit) - if(allocated(this%head)) deallocate(this%head) + close (this%inunit) + if (allocated(this%head)) deallocate (this%head) ! ! -- return return end subroutine finalize - + end module HeadFileReaderModule diff --git a/src/Utilities/Iunit.f90 b/src/Utilities/Iunit.f90 index 41f968a1311..0f109a0fe47 100644 --- a/src/Utilities/Iunit.f90 +++ b/src/Utilities/Iunit.f90 @@ -2,7 +2,7 @@ ! -- assigned to a single package type, as shown below. ! -- row(i) cunit(i) iunit(i)%nval iunit(i)%iunit iunit(i)%ipos ! -- 1 BCF6 1 (1000) (1) -! -- 2 WEL 3 (1001,1003,1005) (2,5,7) +! -- 2 WEL 3 (1001,1003,1005) (2,5,7) ! -- 3 GHB 1 (1002) (4) ! -- 4 EVT 2 (1004,1006) (6,10) ! -- 5 RIV 0 () () @@ -19,8 +19,8 @@ module IunitModule type :: IunitRowType integer(I4B) :: nval = 0 - integer(I4B), allocatable, dimension(:) :: iunit ! unit numbers for this row - integer(I4B), allocatable, dimension(:) :: ipos ! position in the input files character array + integer(I4B), allocatable, dimension(:) :: iunit ! unit numbers for this row + integer(I4B), allocatable, dimension(:) :: ipos ! position in the input files character array end type IunitRowType type :: IunitType @@ -33,7 +33,7 @@ module IunitModule procedure :: getunitnumber end type IunitType - contains +contains subroutine init(this, niunit, cunit) ! ****************************************************************************** @@ -51,12 +51,12 @@ subroutine init(this, niunit, cunit) integer(I4B) :: i ! ------------------------------------------------------------------------------ ! - allocate(this%cunit(niunit)) - allocate(this%iunit(niunit)) + allocate (this%cunit(niunit)) + allocate (this%iunit(niunit)) this%niunit = niunit - do i=1,niunit - this%cunit(i)=cunit(i) - enddo + do i = 1, niunit + this%cunit(i) = cunit(i) + end do ! ! -- Return return @@ -86,41 +86,41 @@ subroutine addfile(this, ftyp, iunit, ipos, namefilename) ! -- Find the row containing ftyp irow = 0 do i = 1, this%niunit - if(this%cunit(i) == ftyp) then + if (this%cunit(i) == ftyp) then irow = i exit - endif - enddo - if(irow == 0) then - write(errmsg, '(a,a)') 'Package type not supported: ', ftyp + end if + end do + if (irow == 0) then + write (errmsg, '(a,a)') 'Package type not supported: ', ftyp call store_error(errmsg) call store_error_filename(namefilename, terminate=.TRUE.) - endif + end if ! ! -- Store the iunit number for this ftyp - if(this%iunit(irow)%nval == 0) then - allocate(this%iunit(irow)%iunit(1)) - allocate(this%iunit(irow)%ipos(1)) - this%iunit(irow)%nval=1 + if (this%iunit(irow)%nval == 0) then + allocate (this%iunit(irow)%iunit(1)) + allocate (this%iunit(irow)%ipos(1)) + this%iunit(irow)%nval = 1 else ! ! -- increase size of iunit - allocate(itemp(this%iunit(irow)%nval)) + allocate (itemp(this%iunit(irow)%nval)) itemp(:) = this%iunit(irow)%iunit(:) - deallocate(this%iunit(irow)%iunit) + deallocate (this%iunit(irow)%iunit) this%iunit(irow)%nval = this%iunit(irow)%nval + 1 - allocate(this%iunit(irow)%iunit(this%iunit(irow)%nval)) + allocate (this%iunit(irow)%iunit(this%iunit(irow)%nval)) this%iunit(irow)%iunit(1:this%iunit(irow)%nval - 1) = itemp(:) ! ! -- increase size of ipos itemp(:) = this%iunit(irow)%ipos(:) - deallocate(this%iunit(irow)%ipos) - allocate(this%iunit(irow)%ipos(this%iunit(irow)%nval)) + deallocate (this%iunit(irow)%ipos) + allocate (this%iunit(irow)%ipos(this%iunit(irow)%nval)) this%iunit(irow)%ipos(1:this%iunit(irow)%nval - 1) = itemp(:) ! ! -- cleanup temp - deallocate(itemp) - endif + deallocate (itemp) + end if this%iunit(irow)%iunit(this%iunit(irow)%nval) = iunit this%iunit(irow)%ipos(this%iunit(irow)%nval) = ipos ! @@ -146,26 +146,26 @@ subroutine getunitnumber(this, ftyp, iunit, iremove) ! -- Find the row irow = 0 do i = 1, this%niunit - if(this%cunit(i) == ftyp) then + if (this%cunit(i) == ftyp) then irow = i exit - endif - enddo + end if + end do ! ! -- Find the unit number. iunit = 0 - if(irow > 0) then + if (irow > 0) then nval = this%iunit(irow)%nval - if(nval > 0) then + if (nval > 0) then iunit = this%iunit(irow)%iunit(nval) - if(iremove > 0) then + if (iremove > 0) then this%iunit(irow)%iunit(nval) = 0 this%iunit(irow)%nval = nval - 1 - endif + end if else iunit = 0 - endif - endif + end if + end if end subroutine getunitnumber end module IunitModule diff --git a/src/Utilities/List.f90 b/src/Utilities/List.f90 index 6b4dc6d5999..dbd807b22ec 100644 --- a/src/Utilities/List.f90 +++ b/src/Utilities/List.f90 @@ -24,13 +24,13 @@ module ListModule procedure, public :: DeallocateBackward procedure, public :: GetNextItem procedure, public :: GetPreviousItem - generic, public :: GetItem => get_item_by_index, get_current_item + generic, public :: GetItem => get_item_by_index, get_current_item procedure, public :: InsertAfter procedure, public :: InsertBefore procedure, public :: Next procedure, public :: Previous procedure, public :: Reset - generic, public :: RemoveNode => remove_node_by_index, remove_this_node + generic, public :: RemoveNode => remove_node_by_index, remove_this_node ! -- Private procedures procedure, private :: get_current_item procedure, private :: get_item_by_index @@ -46,21 +46,21 @@ module ListModule type(ListNodeType), pointer, public :: nextNode => null() type(ListNodeType), pointer, public :: prevNode => null() ! -- Private members - class(*), pointer, private :: Value => null() + class(*), pointer, private :: Value => null() contains ! -- Public procedure - procedure, public :: GetItem + procedure, public :: GetItem ! -- Private procedures procedure, private :: DeallocValue end type ListNodeType - + interface function isEqualIface(obj1, obj2) result(isEqual) class(*), pointer :: obj1, obj2 logical :: isEqual end function end interface - + contains ! -- Public type-bound procedures for ListType @@ -72,16 +72,16 @@ subroutine Add(this, objptr) class(*), pointer, intent(inout) :: objptr ! if (.not. associated(this%firstNode)) then - allocate(this%firstNode) + allocate (this%firstNode) this%firstNode%Value => objptr this%firstNode%prevNode => null() this%lastNode => this%firstNode else - allocate(this%lastNode%nextNode) + allocate (this%lastNode%nextNode) this%lastNode%nextNode%prevNode => this%lastNode this%lastNode%nextNode%value => objptr this%lastNode => this%lastNode%nextNode - endif + end if this%nodeCount = this%nodeCount + 1 return end subroutine Add @@ -106,14 +106,14 @@ subroutine Clear(this, destroy) destroyLocal = .false. if (present(destroy)) then destroyLocal = destroy - endif + end if ! if (.not. associated(this%firstNode)) return ! -- The last node will be deallocated in the loop below. ! Just nullify the pointer to the last node to avoid ! having a dangling pointer. Also nullify currentNode. - nullify(this%lastNode) - nullify(this%currentNode) + nullify (this%lastNode) + nullify (this%currentNode) ! current => this%firstNode do while (associated(current)) @@ -122,12 +122,12 @@ subroutine Clear(this, destroy) ! -- Deallocate the object stored in the current node call current%DeallocValue(destroyLocal) ! -- Deallocate the current node - deallocate(current) + deallocate (current) this%firstNode => next this%nodeCount = this%nodeCount - 1 ! -- Advance to the next node current => next - enddo + end do ! call this%Reset() ! @@ -160,7 +160,7 @@ function ContainsObject(this, obj, isEqual) result(hasObj) logical :: hasObj ! local type(ListNodeType), pointer :: current => null() - + hasObj = .false. current => this%firstNode do while (associated(current)) @@ -168,21 +168,21 @@ function ContainsObject(this, obj, isEqual) result(hasObj) hasObj = .true. return end if - + ! -- Advance to the next node current => current%nextNode - enddo - + end do + ! this means there is no match return - end function - + end function + function arePointersEqual(obj1, obj2) result(areIdentical) class(*), pointer :: obj1, obj2 logical :: areIdentical - areIdentical = associated(obj1, obj2) + areIdentical = associated(obj1, obj2) end function arePointersEqual - + subroutine DeallocateBackward(this, fromNode) ! ************************************************************************** ! DeallocateBackward @@ -205,18 +205,18 @@ subroutine DeallocateBackward(this, fromNode) this%firstNode => fromNode%nextNode else this%firstNode => null() - endif + end if ! -- deallocate fromNode and all previous nodes current => fromNode do while (associated(current)) prev => current%prevNode call current%DeallocValue(.true.) - deallocate(current) + deallocate (current) this%nodeCount = this%nodeCount - 1 current => prev - enddo + end do fromNode => null() - endif + end if ! return end subroutine DeallocateBackward @@ -263,7 +263,7 @@ subroutine InsertAfter(this, objptr, indx) precedingNode => this%get_node_by_index(indx) if (associated(precedingNode%nextNode)) then followingNode => precedingNode%nextNode - allocate(newNode) + allocate (newNode) newNode%Value => objptr newNode%nextNode => followingNode newNode%prevNode => precedingNode @@ -271,11 +271,11 @@ subroutine InsertAfter(this, objptr, indx) followingNode%prevNode => newNode this%nodeCount = this%nodeCount + 1 else - write(line,'(a)') 'Programming error in ListType%insert_after' + write (line, '(a)') 'Programming error in ListType%insert_after' call sim_message(line) call stop_with_error(1) - endif - endif + end if + end if ! return end subroutine InsertAfter @@ -292,10 +292,10 @@ subroutine InsertBefore(this, objptr, targetNode) ! if (.not. associated(targetNode)) then stop 'Programming error, likely in call to ListType%InsertBefore' - endif + end if ! ! Allocate a new list node and point its Value member to the object - allocate(newNode) + allocate (newNode) newNode%Value => objptr ! ! Do the insertion @@ -308,7 +308,7 @@ subroutine InsertBefore(this, objptr, targetNode) ! Insert before first node this%firstNode => newNode newNode%prevNode => null() - endif + end if targetNode%prevNode => newNode this%nodeCount = this%nodeCount + 1 ! @@ -326,7 +326,7 @@ subroutine Next(this) else this%currentNode => null() this%currentNodeIndex = 0 - endif + end if else if (associated(this%currentNode%nextNode)) then this%currentNode => this%currentNode%nextNode @@ -334,8 +334,8 @@ subroutine Next(this) else this%currentNode => null() this%currentNodeIndex = 0 - endif - endif + end if + end if return end subroutine Next @@ -348,7 +348,7 @@ subroutine Previous(this) else this%currentNode => this%currentNode%prevNode this%currentNodeIndex = this%currentNodeIndex - 1 - endif + end if return end subroutine Previous @@ -365,8 +365,8 @@ subroutine remove_node_by_index(this, i, destroyValue) implicit none ! -- dummy class(ListType), intent(inout) :: this - integer(I4B), intent(in) :: i - logical, intent(in) :: destroyValue + integer(I4B), intent(in) :: i + logical, intent(in) :: destroyValue ! -- local type(ListNodeType), pointer :: node ! @@ -374,7 +374,7 @@ subroutine remove_node_by_index(this, i, destroyValue) node => this%get_node_by_index(i) if (associated(node)) then call this%remove_this_node(node, destroyValue) - endif + end if ! return end subroutine remove_node_by_index @@ -382,9 +382,9 @@ end subroutine remove_node_by_index subroutine remove_this_node(this, node, destroyValue) implicit none ! -- dummy - class(ListType), intent(inout) :: this + class(ListType), intent(inout) :: this type(ListNodeType), pointer, intent(inout) :: node - logical, intent(in) :: destroyValue + logical, intent(in) :: destroyValue ! -- local ! logical :: first, last @@ -398,32 +398,32 @@ subroutine remove_this_node(this, node, destroyValue) else node%prevNode%nextNode => null() this%lastNode => node%prevNode - endif + end if else first = .true. - endif + end if if (associated(node%nextNode)) then if (associated(node%prevNode)) then node%prevNode%nextNode => node%nextNode else node%nextNode%prevNode => null() this%firstNode => node%nextNode - endif + end if else last = .true. - endif + end if if (destroyValue) then call node%DeallocValue(destroyValue) - endif - deallocate(node) + end if + deallocate (node) this%nodeCount = this%nodeCount - 1 if (first .and. last) then this%firstNode => null() this%lastNode => null() this%currentNode => null() - endif + end if call this%Reset() - endif + end if ! return end subroutine remove_this_node @@ -439,7 +439,7 @@ function get_current_item(this) result(resultobj) resultobj => null() if (associated(this%currentNode)) then resultobj => this%currentNode%Value - endif + end if return end function get_current_item @@ -466,13 +466,13 @@ function get_item_by_index(this, indx) result(resultobj) ! -- Ensure that this%currentNode is associated if (.not. associated(this%currentNode)) then this%currentNodeIndex = 0 - endif + end if if (this%currentNodeIndex == 0) then if (associated(this%firstNode)) then this%currentNode => this%firstNode this%currentNodeIndex = 1 - endif - endif + end if + end if ! ! -- Check indx position relative to current node index i = 0 @@ -483,28 +483,28 @@ function get_item_by_index(this, indx) result(resultobj) this%currentNode => this%firstNode this%currentNodeIndex = 1 i = 1 - endif + end if else i = this%currentNodeIndex - endif + end if if (i == 0) return ! ! -- If current node is requested node, ! assign pointer and return - if (i==indx) then + if (i == indx) then resultobj => this%currentNode%Value return - endif + end if ! ! -- Iterate from current node to requested node do while (associated(this%currentNode%nextNode)) this%currentNode => this%currentNode%nextNode this%currentNodeIndex = this%currentNodeIndex + 1 - if (this%currentNodeIndex==indx) then + if (this%currentNodeIndex == indx) then resultobj => this%currentNode%Value return - endif - enddo + end if + end do return end function get_item_by_index @@ -533,8 +533,8 @@ function get_node_by_index(this, indx) result(resultnode) if (associated(this%firstNode)) then this%currentNode => this%firstNode this%currentNodeIndex = 1 - endif - endif + end if + end if ! ! -- Check indx position relative to current node index i = 0 @@ -545,28 +545,28 @@ function get_node_by_index(this, indx) result(resultnode) this%currentNode => this%firstNode this%currentNodeIndex = 1 i = 1 - endif + end if else i = this%currentNodeIndex - endif + end if if (i == 0) return ! ! -- If current node is requested node, ! assign pointer and return - if (i==indx) then + if (i == indx) then resultnode => this%currentNode return - endif + end if ! ! -- Iterate from current node to requested node do while (associated(this%currentNode%nextNode)) this%currentNode => this%currentNode%nextNode this%currentNodeIndex = this%currentNodeIndex + 1 - if (this%currentNodeIndex==indx) then + if (this%currentNodeIndex == indx) then resultnode => this%currentNode return - endif - enddo + end if + end do return end function get_node_by_index @@ -602,11 +602,11 @@ subroutine DeallocValue(this, destroy) if (associated(this%Value)) then if (present(destroy)) then if (destroy) then - deallocate(this%Value) - endif - endif - nullify(this%Value) - endif + deallocate (this%Value) + end if + end if + nullify (this%Value) + end if return end subroutine DeallocValue diff --git a/src/Utilities/ListReader.f90 b/src/Utilities/ListReader.f90 index 8e97e0746ac..d40943f2e31 100644 --- a/src/Utilities/ListReader.f90 +++ b/src/Utilities/ListReader.f90 @@ -4,54 +4,54 @@ module ListReaderModule use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & LENAUXNAME, LENLISTLABEL, DONE - use SimModule, only: store_error_unit + use SimModule, only: store_error_unit implicit none private public ListReaderType - + type :: ListReaderType - integer(I4B) :: in = 0 ! unit number of file containing control record - integer(I4B) :: inlist = 0 ! unit number of file from which list will be read - integer(I4B) :: iout = 0 ! unit number to output messages - integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read - integer(I4B) :: ierr = 0 ! error flag - integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined - integer(I4B) :: ibinary = 0 ! flag indicating to read binary list - integer(I4B) :: istart = 0 ! string starting location - integer(I4B) :: istop = 0 ! string ending location - integer(I4B) :: lloc = 0 ! entry number in line - integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file - integer(I4B) :: ndim = 0 ! number of dimensions in model - integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist - integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar - character(len=LENLISTLABEL) :: label = '' ! label for printing list - character(len=:), allocatable, private :: line ! current line - integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist - real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar - character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: boundname => null() ! pointer to boundname - integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar - integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar + integer(I4B) :: in = 0 ! unit number of file containing control record + integer(I4B) :: inlist = 0 ! unit number of file from which list will be read + integer(I4B) :: iout = 0 ! unit number to output messages + integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read + integer(I4B) :: ierr = 0 ! error flag + integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined + integer(I4B) :: ibinary = 0 ! flag indicating to read binary list + integer(I4B) :: istart = 0 ! string starting location + integer(I4B) :: istop = 0 ! string ending location + integer(I4B) :: lloc = 0 ! entry number in line + integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file + integer(I4B) :: ndim = 0 ! number of dimensions in model + integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist + integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar + character(len=LENLISTLABEL) :: label = '' ! label for printing list + character(len=:), allocatable, private :: line ! current line + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist + real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar + character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: boundname => null() ! pointer to boundname + integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar + integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar contains - procedure :: read_list - procedure :: write_list + procedure :: read_list + procedure :: write_list procedure, private :: read_control_record procedure, private :: read_data procedure, private :: set_openclose procedure, private :: read_ascii procedure, private :: read_binary end type ListReaderType - - contains - - subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & + +contains + + subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & rlist, auxvar, auxname, boundname, label) ! ****************************************************************************** ! init -- Initialize the reader @@ -72,7 +72,8 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & real(DP), dimension(:, :), intent(inout), contiguous, pointer :: rlist real(DP), dimension(:, :), intent(inout), contiguous, pointer :: auxvar character(len=LENAUXNAME), dimension(:), intent(inout), target :: auxname - character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, intent(inout) :: boundname + character(len=LENBOUNDNAME), & + dimension(:), pointer, contiguous, intent(inout) :: boundname character(len=LENLISTLABEL), intent(in) :: label ! -- local ! ------------------------------------------------------------------------------ @@ -94,12 +95,12 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & this%boundname => boundname ! ! -- Allocate arrays for storing text and text locations - if(.not. allocated(this%idxtxtrow)) allocate(this%idxtxtrow(0)) - if(.not. allocated(this%idxtxtcol)) allocate(this%idxtxtcol(0)) - if(.not. allocated(this%idxtxtauxrow)) allocate(this%idxtxtauxrow(0)) - if(.not. allocated(this%idxtxtauxcol)) allocate(this%idxtxtauxcol(0)) - if(.not. allocated(this%txtrlist)) allocate(this%txtrlist(0)) - if(.not. allocated(this%txtauxvar)) allocate(this%txtauxvar(0)) + if (.not. allocated(this%idxtxtrow)) allocate (this%idxtxtrow(0)) + if (.not. allocated(this%idxtxtcol)) allocate (this%idxtxtcol(0)) + if (.not. allocated(this%idxtxtauxrow)) allocate (this%idxtxtauxrow(0)) + if (.not. allocated(this%idxtxtauxcol)) allocate (this%idxtxtauxcol(0)) + if (.not. allocated(this%txtrlist)) allocate (this%txtrlist(0)) + if (.not. allocated(this%txtauxvar)) allocate (this%txtauxvar(0)) ! ! -- Read control record call this%read_control_record() @@ -113,7 +114,7 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & ! -- return return end subroutine read_list - + subroutine read_control_record(this) ! ****************************************************************************** ! read_control_record -- Check for a control record, and parse if found @@ -130,7 +131,7 @@ subroutine read_control_record(this) real(DP) :: r ! -- formats character(len=*), parameter :: fmtlsf = & - "(1X,'LIST SCALING FACTOR=',1PG12.5)" + "(1X,'LIST SCALING FACTOR=',1PG12.5)" ! ------------------------------------------------------------------------------ ! ! -- Set default values, which may be changed by control record @@ -141,19 +142,19 @@ subroutine read_control_record(this) ! -- Read to the first non-commented line call u9rdcom(this%in, this%iout, this%line, this%ierr) this%lloc = 1 - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%in) ! ! -- Parse record - select case(this%line(this%istart:this%istop)) - case('OPEN/CLOSE') + select case (this%line(this%istart:this%istop)) + case ('OPEN/CLOSE') call this%set_openclose() end select ! ! -- return return end subroutine read_control_record - + subroutine set_openclose(this) ! ****************************************************************************** ! set_openclose -- set up for open/close file @@ -179,54 +180,54 @@ subroutine set_openclose(this) character(len=LINELENGTH) :: errmsg ! -- formats character(len=*), parameter :: fmtocne = & - "('Specified OPEN/CLOSE file ',(A),' does not exist')" + &"('Specified OPEN/CLOSE file ',(A),' does not exist')" character(len=*), parameter :: fmtobf = & - "(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" + &"(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" character(len=*), parameter :: fmtobfnlist = & - "(1X, 'TO READ ', I0, ' RECORDS.')" + &"(1X, 'TO READ ', I0, ' RECORDS.')" character(len=*), parameter :: fmtofnlist = & - "(1x,'TO READ ', I0, ' RECORDS.')" + &"(1x,'TO READ ', I0, ' RECORDS.')" character(len=*), parameter :: fmtof = & - "(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" + &"(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" ! ------------------------------------------------------------------------------ ! ! -- get filename - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & this%iout, this%in) fname = this%line(this%istart:this%istop) ! ! -- check to see if file OPEN/CLOSE file exists - inquire(file=fname, exist=exists) + inquire (file=fname, exist=exists) if (.not. exists) then - write(errmsg, fmtocne) this%line(this%istart:this%istop) + write (errmsg, fmtocne) this%line(this%istart:this%istop) call store_error(errmsg) call store_error('Specified OPEN/CLOSE file does not exist') call store_error_unit(this%in) - endif + end if ! ! -- Check for (BINARY) keyword - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%in) - if(this%line(this%istart:this%istop) == '(BINARY)') this%ibinary = 1 + if (this%line(this%istart:this%istop) == '(BINARY)') this%ibinary = 1 ! ! -- Open the file depending on ibinary flag this%inlist = nunopn - if(this%ibinary == 1) then + if (this%ibinary == 1) then itmp = this%iout - if(this%iout > 0) then + if (this%iout > 0) then itmp = 0 - write(this%iout, fmtobf) this%inlist, trim(adjustl(fname)) - if(this%nlist > 0) write(this%iout, fmtobfnlist) this%nlist - endif - call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE', fmtarg_opt=form, & + write (this%iout, fmtobf) this%inlist, trim(adjustl(fname)) + if (this%nlist > 0) write (this%iout, fmtobfnlist) this%nlist + end if + call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE', fmtarg_opt=form, & accarg_opt=access) else itmp = this%iout - if(this%iout > 0) then + if (this%iout > 0) then itmp = 0 - write(this%iout, fmtof) this%inlist, trim(adjustl(fname)) - if(this%nlist > 0) write(this%iout, fmtofnlist) this%nlist - endif + write (this%iout, fmtof) this%inlist, trim(adjustl(fname)) + if (this%nlist > 0) write (this%iout, fmtofnlist) this%nlist + end if call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE') end if ! @@ -236,13 +237,13 @@ subroutine set_openclose(this) ! ! -- Read the first line from inlist to be consistent with how the list is ! read when it is included in the package input file - if(this%ibinary /= 1) call u9rdcom(this%inlist, this%iout, this%line, & - this%ierr) + if (this%ibinary /= 1) call u9rdcom(this%inlist, this%iout, this%line, & + this%ierr) ! ! -- return return end subroutine set_openclose - + subroutine read_data(this) ! ****************************************************************************** ! read_data -- read the data @@ -258,20 +259,20 @@ subroutine read_data(this) ! ------------------------------------------------------------------------------ ! ! -- Read the list - if(this%ibinary == 1) then + if (this%ibinary == 1) then call this%read_binary() else call this%read_ascii() - endif + end if ! ! -- if open/close, then close file - if(this%iclose == 1) then - close(this%inlist) - endif + if (this%iclose == 1) then + close (this%inlist) + end if ! -- return return end subroutine read_data - + subroutine read_binary(this) ! ****************************************************************************** ! read_binary -- read the data from a binary file @@ -292,14 +293,14 @@ subroutine read_binary(this) integer(I4B), dimension(:), allocatable :: cellid ! -- formats character(len=*), parameter :: fmtmxlsterronly = & - "('ERROR READING LIST FROM FILE: '," // & - "a,' ON UNIT: ',I0," // & - "' THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & - "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & - " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" + "('ERROR READING LIST FROM FILE: ',& + &a,' ON UNIT: ',I0,& + &' THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER & + &OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST.& + & NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" character(len=*), parameter :: fmtlsterronly = & - "('ERROR READING LIST FROM FILE: '," // & - "1x,a,1x,' ON UNIT: ',I0)" + "('ERROR READING LIST FROM FILE: ',& + &1x,a,1x,' ON UNIT: ',I0)" ! ------------------------------------------------------------------------------ ! ! -- determine array sizes @@ -308,74 +309,74 @@ subroutine read_binary(this) naux = size(this%auxvar, 1) ! ! -- Allocate arrays - allocate(cellid(this%ndim)) + allocate (cellid(this%ndim)) ! ii = 1 readloop: do ! ! -- read layer, row, col, or cell number - read(this%inlist, iostat=this%ierr) cellid + read (this%inlist, iostat=this%ierr) cellid ! -- If not end of record, then store nodenumber, else ! calculate lstend and nlist, and exit readloop - select case(this%ierr) - case(0) + select case (this%ierr) + case (0) ! ! -- Check range - if(ii > mxlist) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtmxlsterronly) fname, this%inlist, ii, mxlist + if (ii > mxlist) then + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtmxlsterronly) fname, this%inlist, ii, mxlist call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- Store node number and read the remainder of the record - if(this%ndim == 1) then + if (this%ndim == 1) then nod = cellid(1) - elseif(this%ndim == 2) then - nod = get_node(cellid(1), 1, cellid(2), & + elseif (this%ndim == 2) then + nod = get_node(cellid(1), 1, cellid(2), & this%mshape(1), 1, this%mshape(2)) else - nod = get_node(cellid(1), cellid(2), cellid(3), & + nod = get_node(cellid(1), cellid(2), cellid(3), & this%mshape(1), this%mshape(2), this%mshape(3)) - endif + end if this%nodelist(ii) = nod - read(this%inlist, iostat=this%ierr) (this%rlist(jj,ii),jj=1,ldim), & - (this%auxvar(ii,jj),jj=1,naux) - if(this%ierr /= 0) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist + read (this%inlist, iostat=this%ierr) (this%rlist(jj, ii), jj=1, ldim), & + (this%auxvar(ii, jj), jj=1, naux) + if (this%ierr /= 0) then + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist call store_error(errmsg, terminate=.TRUE.) - endif + end if ! - case(:-1) + case (:-1) ! ! -- End of record was encountered this%nlist = ii - 1 exit readloop ! - case(1:) + case (1:) ! ! -- Error - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist call store_error(errmsg, terminate=.TRUE.) ! end select ! ! -- If nlist is known, then exit when nlist values have been read - if(this%nlist > 0) then - if(ii == this%nlist) exit readloop - endif + if (this%nlist > 0) then + if (ii == this%nlist) exit readloop + end if ! ! -- increment ii ii = ii + 1 ! - enddo readloop + end do readloop ! ! -- return return end subroutine read_binary - + subroutine read_ascii(this) ! ****************************************************************************** ! read_ascii -- read the data from an ascii file @@ -390,7 +391,7 @@ subroutine read_ascii(this) use ArrayHandlersModule, only: ExpandArray ! -- dummy class(ListReaderType) :: this - ! -- local + ! -- local integer(I4B) :: mxlist, ldim, naux integer(I4B) :: ii, jj, idum, nod, istat, increment real(DP) :: r @@ -400,8 +401,8 @@ subroutine read_ascii(this) ! -- formats character(len=*), parameter :: fmtmxlsterronly = & "('***ERROR READING LIST. & - &THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & - "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & + &THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER "// & + "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST."// & " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" ! ------------------------------------------------------------------------------ ! @@ -413,116 +414,116 @@ subroutine read_ascii(this) this%ntxtauxvar = 0 ! ! -- Allocate arrays - allocate(cellid(this%ndim)) + allocate (cellid(this%ndim)) ! ii = 1 readloop: do ! ! -- First line was already read, so don't read again - if(ii /= 1) call u9rdcom(this%inlist, 0, this%line, this%ierr) + if (ii /= 1) call u9rdcom(this%inlist, 0, this%line, this%ierr) ! ! -- If this is an unknown-length list, then check for END. ! If found, then backspace, set nlist, and exit readloop. - if(this%nlist < 0) then + if (this%nlist < 0) then this%lloc = 1 call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%inlist) - if(this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then + if (this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then ! If ierr < 0, backspace was already performed in u9rdcom, so only ! need to backspace if END was found. if (this%ierr == 0) then - backspace(this%inlist) - endif + backspace (this%inlist) + end if this%nlist = ii - 1 exit readloop - endif - endif + end if + end if ! ! -- Check range - if(ii > mxlist) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtmxlsterronly) ii, mxlist + if (ii > mxlist) then + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtmxlsterronly) ii, mxlist call store_error(errmsg) - errmsg = 'Error occurred reading line: ' // trim(this%line) + errmsg = 'Error occurred reading line: '//trim(this%line) call store_error(errmsg) call store_error_unit(this%inlist) - endif + end if ! ! -- Read layer, row, column or cell number and assign to nodelist this%lloc = 1 - if(this%ndim == 3) then + if (this%ndim == 3) then ! ! -- Grid is structured; read layer, row, column - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(1), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(2), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(3), r, this%iout, this%inlist) ! ! -- Check for illegal grid location - if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then - write(errmsg, *) ' Layer number in list is outside of the grid', & - cellid(1) - call store_error(errmsg) + if (cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then + write (errmsg, *) ' Layer number in list is outside of the grid', & + cellid(1) + call store_error(errmsg) end if - if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then - write(errmsg, *) ' Row number in list is outside of the grid', & - cellid(2) - call store_error(errmsg) + if (cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then + write (errmsg, *) ' Row number in list is outside of the grid', & + cellid(2) + call store_error(errmsg) end if - if(cellid(3) < 1 .or. cellid(3) > this%mshape(3)) then - write(errmsg, *) ' Column number in list is outside of the grid', & - cellid(3) - call store_error(errmsg) + if (cellid(3) < 1 .or. cellid(3) > this%mshape(3)) then + write (errmsg, *) ' Column number in list is outside of the grid', & + cellid(3) + call store_error(errmsg) end if ! ! -- Calculate nodenumber and put in nodelist - nod = get_node(cellid(1), cellid(2), cellid(3), & + nod = get_node(cellid(1), cellid(2), cellid(3), & this%mshape(1), this%mshape(2), this%mshape(3)) - elseif(this%ndim == 2) then + elseif (this%ndim == 2) then ! ! -- Grid is disv - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(1), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(2), r, this%iout, this%inlist) ! ! -- Check for illegal grid location - if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then - write(errmsg, *) ' Layer number in list is outside of the grid', & - cellid(1) - call store_error(errmsg) + if (cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then + write (errmsg, *) ' Layer number in list is outside of the grid', & + cellid(1) + call store_error(errmsg) end if - if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then - write(errmsg, *) ' Cell2d number in list is outside of the grid', & - cellid(2) - call store_error(errmsg) + if (cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then + write (errmsg, *) ' Cell2d number in list is outside of the grid', & + cellid(2) + call store_error(errmsg) end if ! ! -- Calculate nodenumber and put in nodelist - nod = get_node(cellid(1), 1, cellid(2), & + nod = get_node(cellid(1), 1, cellid(2), & this%mshape(1), 1, this%mshape(2)) else ! ! -- Grid is unstructured; read layer and celld2d number - call urword(this%line, this%lloc, this%istart, this%istop, 2, nod, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, nod, r, & this%iout, this%inlist) - if(nod < 1 .or. nod > this%mshape(1)) then - write(errmsg, *) ' Node number in list is outside of the grid', nod - call store_error(errmsg) + if (nod < 1 .or. nod > this%mshape(1)) then + write (errmsg, *) ' Node number in list is outside of the grid', nod + call store_error(errmsg) end if ! - endif + end if ! ! -- Assign nod to nodelist this%nodelist(ii) = nod ! ! -- Read rlist do jj = 1, ldim - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & r, this%iout, this%inlist) - read(this%line(this%istart:this%istop), *, iostat=istat) r + read (this%line(this%istart:this%istop), *, iostat=istat) r ! ! -- If a double precision value, then store in rlist, otherwise store ! the text name and location @@ -531,25 +532,25 @@ subroutine read_ascii(this) else this%rlist(jj, ii) = DZERO this%ntxtrlist = this%ntxtrlist + 1 - if(this%ntxtrlist > size(this%txtrlist)) then + if (this%ntxtrlist > size(this%txtrlist)) then increment = int(size(this%txtrlist) * 0.2) increment = max(100, increment) call ExpandArray(this%txtrlist, increment) call ExpandArray(this%idxtxtrow, increment) call ExpandArray(this%idxtxtcol, increment) - endif + end if this%txtrlist(this%ntxtrlist) = this%line(this%istart:this%istop) this%idxtxtrow(this%ntxtrlist) = ii this%idxtxtcol(this%ntxtrlist) = jj - endif + end if ! - enddo + end do ! ! -- Read auxvar do jj = 1, naux - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & r, this%iout, this%inlist) - read(this%line(this%istart:this%istop), *, iostat=istat) r + read (this%line(this%istart:this%istop), *, iostat=istat) r ! ! -- If a double precision value, then store in auxvar, otherwise store ! the text name and location @@ -558,46 +559,46 @@ subroutine read_ascii(this) else this%auxvar(jj, ii) = DZERO this%ntxtauxvar = this%ntxtauxvar + 1 - if(this%ntxtauxvar > size(this%txtauxvar)) then + if (this%ntxtauxvar > size(this%txtauxvar)) then increment = int(size(this%txtauxvar) * 0.2) increment = max(100, increment) call ExpandArray(this%txtauxvar, increment) call ExpandArray(this%idxtxtauxrow, increment) call ExpandArray(this%idxtxtauxcol, increment) - endif + end if this%txtauxvar(this%ntxtauxvar) = this%line(this%istart:this%istop) this%idxtxtauxrow(this%ntxtauxvar) = ii this%idxtxtauxcol(this%ntxtauxvar) = jj - endif + end if ! - enddo + end do ! ! -- Read the boundary names (only supported for ascii input) if (this%inamedbound > 0) then call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%inlist) this%boundname(ii) = this%line(this%istart:this%istop) - endif + end if ! ! -- If nlist is known, then exit when nlist values have been read - if(this%nlist > 0) then - if(ii == this%nlist) exit readloop - endif + if (this%nlist > 0) then + if (ii == this%nlist) exit readloop + end if ! ! -- increment ii row counter ii = ii + 1 ! - enddo readloop + end do readloop ! ! -- Stop if errors were detected - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error_unit(this%inlist) - endif + end if ! ! -- return return end subroutine read_ascii - + subroutine write_list(this) ! ****************************************************************************** ! write_list -- Write input data to a list @@ -606,7 +607,7 @@ subroutine write_list(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & TABLEFT, TABCENTER use InputOutputModule, only: ulstlb, get_ijk use TableModule, only: TableType, table_cr @@ -638,51 +639,51 @@ subroutine write_list(this) ! contains the column headers (except for boundname and auxnames) ipos = index(this%label, 'NO.') if (ipos /= 0) then - write(cpos,'(i10)') ipos + 3 - fmtlstbn = '(a' // trim(adjustl(cpos)) + write (cpos, '(i10)') ipos + 3 + fmtlstbn = '(a'//trim(adjustl(cpos)) else fmtlstbn = '(a7' end if ! -- sequence number, layer, row, and column. - if(size(this%mshape) == 3) then + if (size(this%mshape) == 3) then ntabcols = 4 - fmtlstbn = trim(fmtlstbn) // ',a7,a7,a7' - ! - ! -- sequence number, layer, and cell2d. - else if(size(this%mshape) == 2) then + fmtlstbn = trim(fmtlstbn)//',a7,a7,a7' + ! + ! -- sequence number, layer, and cell2d. + else if (size(this%mshape) == 2) then ntabcols = 3 - fmtlstbn = trim(fmtlstbn) // ',a7,a7' - ! - ! -- sequence number and node. + fmtlstbn = trim(fmtlstbn)//',a7,a7' + ! + ! -- sequence number and node. else ntabcols = 2 - fmtlstbn = trim(fmtlstbn) // ',a7' + fmtlstbn = trim(fmtlstbn)//',a7' end if ! ! -- Add fields for non-optional real values ntabcols = ntabcols + ldim do i = 1, ldim - fmtlstbn = trim(fmtlstbn) // ',a16' + fmtlstbn = trim(fmtlstbn)//',a16' end do ! ! -- Add field for boundary name if (this%inamedbound == 1) then ntabcols = ntabcols + 1 - fmtlstbn = trim(fmtlstbn) // ',a16' + fmtlstbn = trim(fmtlstbn)//',a16' end if ! ! -- Add fields for auxiliary variables ntabcols = ntabcols + naux do i = 1, naux - fmtlstbn = trim(fmtlstbn) // ',a16' + fmtlstbn = trim(fmtlstbn)//',a16' end do - fmtlstbn = trim(fmtlstbn) // ')' + fmtlstbn = trim(fmtlstbn)//')' ! ! -- allocate words - allocate(words(ntabcols)) + allocate (words(ntabcols)) ! ! -- parse this%label into words - read(this%label, fmtlstbn) (words(i), i=1, ntabcols) + read (this%label, fmtlstbn) (words(i), i=1, ntabcols) ! ! -- initialize the input table object call table_cr(inputtab, ' ', ' ') @@ -723,7 +724,7 @@ subroutine write_list(this) ! -- discretization if (size(this%mshape) == 3) then nod = this%nodelist(ii) - call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & + call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & i, j, k) call inputtab%add_term(k) call inputtab%add_term(i) @@ -740,7 +741,7 @@ subroutine write_list(this) ! ! -- non-optional variables do jj = 1, ldim - call inputtab%add_term(this%rlist(jj,ii)) + call inputtab%add_term(this%rlist(jj, ii)) end do ! ! -- boundname @@ -750,18 +751,18 @@ subroutine write_list(this) ! ! -- aux variables do jj = 1, naux - call inputtab%add_term(this%auxvar(jj,ii)) + call inputtab%add_term(this%auxvar(jj, ii)) end do - end do + end do ! ! -- deallocate the local variables call inputtab%table_da() - deallocate(inputtab) - nullify(inputtab) - deallocate(words) + deallocate (inputtab) + nullify (inputtab) + deallocate (words) ! ! -- return return end subroutine write_list - + end module ListReaderModule diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 8d176302971..5bafd6b0ff1 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -1,46 +1,46 @@ module MemoryTypeModule - + use KindModule, only: DP, LGP, I4B - use ConstantsModule, only: LENMEMPATH, LENMEMADDRESS, LENTIMESERIESNAME, & - LENVARNAME, MAXMEMRANK, LENMEMTYPE, & - TABSTRING, TABINTEGER, & + use ConstantsModule, only: LENMEMPATH, LENMEMADDRESS, LENTIMESERIESNAME, & + LENVARNAME, MAXMEMRANK, LENMEMTYPE, & + TABSTRING, TABINTEGER, & TABCENTER, TABLEFT, TABRIGHT use TableModule, only: TableType use MemoryHelperModule, only: create_mem_address - + implicit none private public :: MemoryType - + type MemoryType - character(len=LENVARNAME) :: name !< name of the array - character(len=LENVARNAME) :: mastername = 'none' !< name of the master array - character(len=LENMEMPATH) :: path !< path to memory object - character(len=LENMEMPATH) :: masterPath = 'none' !< path to master memory object - character(len=LENMEMTYPE) :: memtype !< type (INTEGER or DOUBLE) - integer(I4B) :: id !< id, not used - integer(I4B) :: nrealloc = 0 !< number of times reallocated - integer(I4B) :: isize !< size of the array - integer(I4B) :: set_handler_idx = 0 !< index of side effect handler for external access - logical(LGP) :: master = .true. !< master copy, others point to this one - character(len=:), pointer :: strsclr => null() !< pointer to the character string - logical(LGP), pointer :: logicalsclr => null() !< pointer to the logical - integer(I4B), pointer :: intsclr => null() !< pointer to the integer - real(DP), pointer :: dblsclr => null() !< pointer to the double - character(len=:), dimension(:), pointer, contiguous :: astr1d => null() !< pointer to the 1d character string array - integer(I4B), dimension(:), pointer, contiguous :: aint1d => null() !< pointer to 1d integer array - integer(I4B), dimension(:, :), pointer, contiguous :: aint2d => null() !< pointer to 2d integer array - integer(I4B), dimension(:, :, :), pointer, contiguous :: aint3d => null() !< pointer to 3d integer array - real(DP), dimension(:), pointer, contiguous :: adbl1d => null() !< pointer to 1d double array - real(DP), dimension(:, :), pointer, contiguous :: adbl2d => null() !< pointer to 2d double array - real(DP), dimension(:, :, :), pointer, contiguous :: adbl3d => null() !< pointer to 3d double array + character(len=LENVARNAME) :: name !< name of the array + character(len=LENVARNAME) :: mastername = 'none' !< name of the master array + character(len=LENMEMPATH) :: path !< path to memory object + character(len=LENMEMPATH) :: masterPath = 'none' !< path to master memory object + character(len=LENMEMTYPE) :: memtype !< type (INTEGER or DOUBLE) + integer(I4B) :: id !< id, not used + integer(I4B) :: nrealloc = 0 !< number of times reallocated + integer(I4B) :: isize !< size of the array + integer(I4B) :: set_handler_idx = 0 !< index of side effect handler for external access + logical(LGP) :: master = .true. !< master copy, others point to this one + character(len=:), pointer :: strsclr => null() !< pointer to the character string + logical(LGP), pointer :: logicalsclr => null() !< pointer to the logical + integer(I4B), pointer :: intsclr => null() !< pointer to the integer + real(DP), pointer :: dblsclr => null() !< pointer to the double + character(len=:), dimension(:), pointer, contiguous :: astr1d => null() !< pointer to the 1d character string array + integer(I4B), dimension(:), pointer, contiguous :: aint1d => null() !< pointer to 1d integer array + integer(I4B), dimension(:, :), pointer, contiguous :: aint2d => null() !< pointer to 2d integer array + integer(I4B), dimension(:, :, :), pointer, contiguous :: aint3d => null() !< pointer to 3d integer array + real(DP), dimension(:), pointer, contiguous :: adbl1d => null() !< pointer to 1d double array + real(DP), dimension(:, :), pointer, contiguous :: adbl2d => null() !< pointer to 2d double array + real(DP), dimension(:, :, :), pointer, contiguous :: adbl3d => null() !< pointer to 3d double array contains procedure :: table_entry procedure :: mt_associated end type - - contains - + +contains + subroutine table_entry(this, memtab) ! -- dummy class(MemoryType) :: this @@ -56,7 +56,7 @@ subroutine table_entry(this, memtab) if (ipos < 1) then ipos = 16 else - ipos = min(16,ipos-1) + ipos = min(16, ipos - 1) end if cmem = this%memtype(1:ipos) ! @@ -81,17 +81,17 @@ function mt_associated(this) result(al) class(MemoryType) :: this logical :: al al = .false. - if(associated(this%strsclr)) al = .true. - if(associated(this%logicalsclr)) al = .true. - if(associated(this%intsclr)) al = .true. - if(associated(this%dblsclr)) al = .true. - if(associated(this%astr1d)) al = .true. - if(associated(this%aint1d)) al = .true. - if(associated(this%aint2d)) al = .true. - if(associated(this%aint3d)) al = .true. - if(associated(this%adbl1d)) al = .true. - if(associated(this%adbl2d)) al = .true. - if(associated(this%adbl3d)) al = .true. + if (associated(this%strsclr)) al = .true. + if (associated(this%logicalsclr)) al = .true. + if (associated(this%intsclr)) al = .true. + if (associated(this%dblsclr)) al = .true. + if (associated(this%astr1d)) al = .true. + if (associated(this%aint1d)) al = .true. + if (associated(this%aint2d)) al = .true. + if (associated(this%aint3d)) al = .true. + if (associated(this%adbl1d)) al = .true. + if (associated(this%adbl2d)) al = .true. + if (associated(this%adbl3d)) al = .true. end function mt_associated - -end module MemoryTypeModule \ No newline at end of file + +end module MemoryTypeModule diff --git a/src/Utilities/Memory/MemoryHelper.f90 b/src/Utilities/Memory/MemoryHelper.f90 index a06d20c2255..e14541398c6 100644 --- a/src/Utilities/Memory/MemoryHelper.f90 +++ b/src/Utilities/Memory/MemoryHelper.f90 @@ -1,6 +1,7 @@ module MemoryHelperModule use KindModule, only: I4B, LGP - use ConstantsModule, only: LENMEMPATH, LENMEMSEPARATOR, LENMEMADDRESS, LENVARNAME, LENCOMPONENTNAME + use ConstantsModule, only: LENMEMPATH, LENMEMSEPARATOR, LENMEMADDRESS, & + LENVARNAME, LENCOMPONENTNAME use SimModule, only: store_error use SimVariablesModule, only: errmsg @@ -13,24 +14,24 @@ module MemoryHelperModule !> @brief returns the path to the memory object !! !! Returns the path to the location in the memory manager where - !! the variables for this (sub)component are stored, the 'memoryPath' + !! the variables for this (sub)component are stored, the 'memoryPath' !! !! NB: no need to trim the input parameters !< function create_mem_path(component, subcomponent) result(memory_path) - character(len=*), intent(in) :: component !< name of the solution, model, or exchange - character(len=*), intent(in), optional :: subcomponent !< name of the package (optional) - character(len=LENMEMPATH) :: memory_path !< the memory path - + character(len=*), intent(in) :: component !< name of the solution, model, or exchange + character(len=*), intent(in), optional :: subcomponent !< name of the package (optional) + character(len=LENMEMPATH) :: memory_path !< the memory path + call mem_check_length(component, LENCOMPONENTNAME, "solution/model/exchange") - call mem_check_length(subcomponent, LENCOMPONENTNAME, "package") - + call mem_check_length(subcomponent, LENCOMPONENTNAME, "package") + if (present(subcomponent)) then - memory_path = trim(component) // memPathSeparator // trim(subcomponent) + memory_path = trim(component)//memPathSeparator//trim(subcomponent) else memory_path = trim(component) end if - + end function create_mem_path !> @brief returns the address string of the memory object @@ -40,24 +41,24 @@ end function create_mem_path !! NB: no need to trim the input parameters !< function create_mem_address(mem_path, var_name) result(mem_address) - character(len=*), intent(in) :: mem_path !< path to the memory object - character(len=*), intent(in) :: var_name !< name of the stored variable + character(len=*), intent(in) :: mem_path !< path to the memory object + character(len=*), intent(in) :: var_name !< name of the stored variable character(len=LENMEMADDRESS) :: mem_address !< full address string to the memory object call mem_check_length(mem_path, LENMEMPATH, "memory path") call mem_check_length(var_name, LENVARNAME, "variable") - mem_address = trim(mem_path) // memPathSeparator // trim(var_name) + mem_address = trim(mem_path)//memPathSeparator//trim(var_name) - end function create_mem_address + end function create_mem_address !> @brief Split a memory address string into memory path and variable name !< subroutine split_mem_address(mem_address, mem_path, var_name, success) - character(len=*), intent(in) :: mem_address !< the full memory address string - character(len=LENMEMPATH), intent(out) :: mem_path !< the memory path - character(len=LENVARNAME), intent(out) :: var_name !< the variable name - logical(LGP), intent(out) :: success !< true when successful + character(len=*), intent(in) :: mem_address !< the full memory address string + character(len=LENMEMPATH), intent(out) :: mem_path !< the memory path + character(len=LENVARNAME), intent(out) :: var_name !< the variable name + logical(LGP), intent(out) :: success !< true when successful ! local integer(I4B) :: idx @@ -65,48 +66,47 @@ subroutine split_mem_address(mem_address, mem_path, var_name, success) ! if no separator, or it's at the end of the string, ! the memory address is not valid: - if(idx < 1 .or. idx == len(mem_address)) then + if (idx < 1 .or. idx == len(mem_address)) then success = .false. mem_path = '' var_name = '' else success = .true. - mem_path = mem_address(:idx-1) - var_name = mem_address(idx+1:) + mem_path = mem_address(:idx - 1) + var_name = mem_address(idx + 1:) end if - + end subroutine split_mem_address !> @brief Split the memory path into component(s) !! - !! NB: when there is no subcomponent in the path, the + !! NB: when there is no subcomponent in the path, the !! value for @par subcomponent is set to an empty string. !< - subroutine split_mem_path(mem_path, component, subcomponent) - character(len=*), intent(in) :: mem_path !< path to the memory object - character(len=LENCOMPONENTNAME), intent(out) :: component !< name of the component (solution, model, exchange) - character(len=LENCOMPONENTNAME), intent(out) :: subcomponent !< name of the subcomponent (package) - + subroutine split_mem_path(mem_path, component, subcomponent) + character(len=*), intent(in) :: mem_path !< path to the memory object + character(len=LENCOMPONENTNAME), intent(out) :: component !< name of the component (solution, model, exchange) + character(len=LENCOMPONENTNAME), intent(out) :: subcomponent !< name of the subcomponent (package) + ! local integer(I4B) :: idx idx = index(mem_path, memPathSeparator, back=.true.) ! if the separator is found at the end of the string, ! the path is invalid: - if(idx == len(mem_path)) then - write(errmsg, '(*(G0))') & + if (idx == len(mem_path)) then + write (errmsg, '(*(G0))') & 'Fatal error in Memory Manager, cannot split invalid memory path: ', & - mem_path + mem_path ! -- store error and stop program execution call store_error(errmsg, terminate=.TRUE.) end if - if (idx > 0) then ! when found: - component = mem_path(:idx-1) - subcomponent = mem_path(idx+1:) + component = mem_path(:idx - 1) + subcomponent = mem_path(idx + 1:) else ! when not found, there apparently is no subcomponent: component = mem_path @@ -119,7 +119,7 @@ end subroutine split_mem_path !! !! The string will be trimmed before the measurement. !! - !! @warning{if the length exceeds the maximum, a message is recorded + !! @warning{if the length exceeds the maximum, a message is recorded !! and the program will be stopped} !! !! The description should describe the part of the address that is checked @@ -127,13 +127,13 @@ end subroutine split_mem_path !! itself !< subroutine mem_check_length(name, max_length, description) - character(len=*), intent(in) :: name !< string to be checked - integer(I4B), intent(in) :: max_length !< maximum length + character(len=*), intent(in) :: name !< string to be checked + integer(I4B), intent(in) :: max_length !< maximum length character(len=*), intent(in) :: description !< a descriptive string - - if(len(trim(name)) > max_length) then - write(errmsg, '(*(G0))') & - 'Fatal error in Memory Manager, length of ', description, ' must be ', & + + if (len(trim(name)) > max_length) then + write (errmsg, '(*(G0))') & + 'Fatal error in Memory Manager, length of ', description, ' must be ', & max_length, ' characters or less: ', name, '(len=', len(trim(name)), ')' ! -- store error and stop program execution @@ -141,4 +141,4 @@ subroutine mem_check_length(name, max_length, description) end if end subroutine mem_check_length -end module MemoryHelperModule \ No newline at end of file +end module MemoryHelperModule diff --git a/src/Utilities/Memory/MemoryList.f90 b/src/Utilities/Memory/MemoryList.f90 index 15210b6135f..94e5045398a 100644 --- a/src/Utilities/Memory/MemoryList.f90 +++ b/src/Utilities/Memory/MemoryList.f90 @@ -4,7 +4,7 @@ module MemoryListModule use ListModule, only: ListType private public :: MemoryListType - + type :: MemoryListType type(ListType), private :: list contains @@ -13,9 +13,9 @@ module MemoryListModule procedure :: count procedure :: clear end type MemoryListType - - contains - + +contains + subroutine add(this, mt) class(MemoryListType) :: this type(MemoryType), pointer :: mt @@ -23,7 +23,7 @@ subroutine add(this, mt) obj => mt call this%list%add(obj) end subroutine add - + function get(this, ipos) result(res) class(MemoryListType) :: this integer(I4B), intent(in) :: ipos @@ -36,7 +36,7 @@ function get(this, ipos) result(res) end select return end function get - + function count(this) result(nval) class(MemoryListType) :: this integer(I4B) :: nval @@ -48,5 +48,5 @@ subroutine clear(this) class(MemoryListType) :: this call this%list%Clear() end subroutine clear - -end module MemoryListModule \ No newline at end of file + +end module MemoryListModule diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index 4642a5b8203..6cb62978bac 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1,20 +1,20 @@ module MemoryManagerModule - use KindModule, only: DP, LGP, I4B, I8B - use ConstantsModule, only: DZERO, DONE, & - DEM3, DEM6, DEM9, DEP3, DEP6, DEP9, & - LENMEMPATH, LENMEMSEPARATOR, LENVARNAME, & - LENCOMPONENTNAME, LINELENGTH, LENMEMTYPE, & - LENMEMADDRESS, TABSTRING, TABUCSTRING, & - TABINTEGER, TABREAL, TABCENTER, TABLEFT, & - TABRIGHT - use SimVariablesModule, only: errmsg - use SimModule, only: store_error, count_errors - use MemoryTypeModule, only: MemoryType - use MemoryListModule, only: MemoryListType - use MemoryHelperModule, only: mem_check_length, split_mem_path - use TableModule, only: TableType, table_cr - + use KindModule, only: DP, LGP, I4B, I8B + use ConstantsModule, only: DZERO, DONE, & + DEM3, DEM6, DEM9, DEP3, DEP6, DEP9, & + LENMEMPATH, LENMEMSEPARATOR, LENVARNAME, & + LENCOMPONENTNAME, LINELENGTH, LENMEMTYPE, & + LENMEMADDRESS, TABSTRING, TABUCSTRING, & + TABINTEGER, TABREAL, TABCENTER, TABLEFT, & + TABRIGHT + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, count_errors + use MemoryTypeModule, only: MemoryType + use MemoryListModule, only: MemoryListType + use MemoryHelperModule, only: mem_check_length, split_mem_path + use TableModule, only: TableType, table_cr + implicit none private public :: mem_allocate @@ -28,7 +28,7 @@ module MemoryManagerModule public :: mem_da public :: mem_set_print_option public :: get_from_memorylist - + public :: get_mem_type public :: get_mem_rank public :: get_mem_elem_size @@ -37,7 +37,7 @@ module MemoryManagerModule public :: copy_dbl1d public :: memorylist - + type(MemoryListType) :: memorylist type(TableType), pointer :: memtab => null() integer(I8B) :: nvalues_alogical = 0 @@ -47,65 +47,65 @@ module MemoryManagerModule integer(I4B) :: iprmem = 0 interface mem_allocate - module procedure allocate_logical, & - allocate_str, allocate_str1d, & - allocate_int, allocate_int1d, allocate_int2d, & - allocate_int3d, & - allocate_dbl, allocate_dbl1d, allocate_dbl2d, & - allocate_dbl3d + module procedure allocate_logical, & + allocate_str, allocate_str1d, & + allocate_int, allocate_int1d, allocate_int2d, & + allocate_int3d, & + allocate_dbl, allocate_dbl1d, allocate_dbl2d, & + allocate_dbl3d end interface mem_allocate - + interface mem_checkin - module procedure checkin_int1d, & - checkin_dbl1d + module procedure checkin_int1d, & + checkin_dbl1d end interface mem_checkin - + interface mem_reallocate - module procedure reallocate_int1d, reallocate_int2d, reallocate_dbl1d, & - reallocate_dbl2d, reallocate_str1d + module procedure reallocate_int1d, reallocate_int2d, reallocate_dbl1d, & + reallocate_dbl2d, reallocate_str1d end interface mem_reallocate - + interface mem_setptr - module procedure setptr_logical, & - setptr_int, setptr_int1d, setptr_int2d, setptr_int3d, & - setptr_dbl, setptr_dbl1d, setptr_dbl2d, setptr_dbl3d + module procedure setptr_logical, & + setptr_int, setptr_int1d, setptr_int2d, setptr_int3d, & + setptr_dbl, setptr_dbl1d, setptr_dbl2d, setptr_dbl3d end interface mem_setptr - + interface mem_copyptr - module procedure copyptr_int1d, copyptr_int2d, & - copyptr_dbl1d, copyptr_dbl2d + module procedure copyptr_int1d, copyptr_int2d, & + copyptr_dbl1d, copyptr_dbl2d end interface mem_copyptr interface mem_reassignptr - module procedure reassignptr_int, & - reassignptr_int1d, reassignptr_int2d, & - reassignptr_dbl1d, reassignptr_dbl2d + module procedure reassignptr_int, & + reassignptr_int1d, reassignptr_int2d, & + reassignptr_dbl1d, reassignptr_dbl2d end interface mem_reassignptr interface mem_deallocate - module procedure deallocate_logical, & - deallocate_str, deallocate_str1d, & - deallocate_int, deallocate_int1d, deallocate_int2d, & - deallocate_int3d, & - deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & - deallocate_dbl3d + module procedure deallocate_logical, & + deallocate_str, deallocate_str1d, & + deallocate_int, deallocate_int1d, deallocate_int2d, & + deallocate_int3d, & + deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & + deallocate_dbl3d end interface mem_deallocate - contains - +contains + !> @ brief Get the variable memory type !! !! Returns any of 'LOGICAL', 'INTEGER', 'DOUBLE', 'STRING'. !! returns 'UNKNOWN' when the variable is not found. !< subroutine get_mem_type(name, mem_path, var_type) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - character(len=LENMEMTYPE), intent(out) :: var_type !< memory type + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + character(len=LENMEMTYPE), intent(out) :: var_type !< memory type ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found - ! -- code + ! -- code mt => null() var_type = 'UNKNOWN' call get_from_memorylist(name, mem_path, mt, found) @@ -116,19 +116,19 @@ subroutine get_mem_type(name, mem_path, var_type) ! -- return return end subroutine get_mem_type - + !> @ brief Get the variable rank !! !! Returns rank = -1 when not found. !< subroutine get_mem_rank(name, mem_path, rank) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< mem_path - integer(I4B), intent(out) :: rank !< rank + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< mem_path + integer(I4B), intent(out) :: rank !< rank ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found - ! -- code + ! -- code ! ! -- initialize rank to a value to communicate failure rank = -1 @@ -138,29 +138,29 @@ subroutine get_mem_rank(name, mem_path, rank) ! ! -- set rank if (found) then - if(associated(mt%logicalsclr)) rank = 0 - if(associated(mt%intsclr)) rank = 0 - if(associated(mt%dblsclr)) rank = 0 - if(associated(mt%aint1d)) rank = 1 - if(associated(mt%aint2d)) rank = 2 - if(associated(mt%aint3d)) rank = 3 - if(associated(mt%adbl1d)) rank = 1 - if(associated(mt%adbl2d)) rank = 2 - if(associated(mt%adbl3d)) rank = 3 - end if + if (associated(mt%logicalsclr)) rank = 0 + if (associated(mt%intsclr)) rank = 0 + if (associated(mt%dblsclr)) rank = 0 + if (associated(mt%aint1d)) rank = 1 + if (associated(mt%aint2d)) rank = 2 + if (associated(mt%aint3d)) rank = 3 + if (associated(mt%adbl1d)) rank = 1 + if (associated(mt%adbl2d)) rank = 2 + if (associated(mt%adbl3d)) rank = 3 + end if ! ! -- return return - end subroutine get_mem_rank - + end subroutine get_mem_rank + !> @ brief Get the memory size of a single element of the stored variable !! !! Memory size in bytes, returns size = -1 when not found. !< subroutine get_mem_elem_size(name, mem_path, size) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), intent(out) :: size !< size of the variable in bytes + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(out) :: size !< size of the variable in bytes ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found @@ -173,8 +173,8 @@ subroutine get_mem_elem_size(name, mem_path, size) call get_from_memorylist(name, mem_path, mt, found) ! ! -- set memory size - if (found) then - select case(mt%memtype(1:index(mt%memtype,' '))) + if (found) then + select case (mt%memtype(1:index(mt%memtype, ' '))) case ('STRING') size = 1 case ('LOGICAL') @@ -183,22 +183,22 @@ subroutine get_mem_elem_size(name, mem_path, size) size = 4 case ('DOUBLE') size = 8 - end select + end select end if ! ! -- return return end subroutine get_mem_elem_size - + !> @ brief Get the variable memory shape !! !! Returns an integer array with the shape (Fortran ordering), !! and set shape(1) = -1 when not found. !< subroutine get_mem_shape(name, mem_path, mem_shape) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), dimension(:), intent(out) :: mem_shape !< shape of the variable + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), dimension(:), intent(out) :: mem_shape !< shape of the variable ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found @@ -209,16 +209,16 @@ subroutine get_mem_shape(name, mem_path, mem_shape) ! ! -- set shape if (found) then - if(associated(mt%logicalsclr)) mem_shape = shape(mt%logicalsclr) - if(associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr) - if(associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr) - if(associated(mt%aint1d)) mem_shape = shape(mt%aint1d) - if(associated(mt%aint2d)) mem_shape = shape(mt%aint2d) - if(associated(mt%aint3d)) mem_shape = shape(mt%aint3d) - if(associated(mt%adbl1d)) mem_shape = shape(mt%adbl1d) - if(associated(mt%adbl2d)) mem_shape = shape(mt%adbl2d) - if(associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d) - ! -- to communicate failure + if (associated(mt%logicalsclr)) mem_shape = shape(mt%logicalsclr) + if (associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr) + if (associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr) + if (associated(mt%aint1d)) mem_shape = shape(mt%aint1d) + if (associated(mt%aint2d)) mem_shape = shape(mt%aint2d) + if (associated(mt%aint3d)) mem_shape = shape(mt%aint3d) + if (associated(mt%adbl1d)) mem_shape = shape(mt%adbl1d) + if (associated(mt%adbl2d)) mem_shape = shape(mt%adbl2d) + if (associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d) + ! -- to communicate failure else mem_shape(1) = -1 end if @@ -226,19 +226,19 @@ subroutine get_mem_shape(name, mem_path, mem_shape) ! -- return return end subroutine get_mem_shape - + !> @ brief Get the number of elements for this variable !! !! Returns with isize = -1 when not found. !< subroutine get_isize(name, mem_path, isize) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), intent(out) :: isize !< number of elements (flattened) + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(out) :: isize !< number of elements (flattened) ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found - ! -- code + ! -- code ! ! -- initialize isize to a value to communicate failure isize = -1 @@ -254,19 +254,19 @@ subroutine get_isize(name, mem_path, isize) ! -- return return end subroutine get_isize - + !> @ brief Get a memory type entry from the memory list !! !! Default value for @par check is .true. which means that this !! routine will kill the program when the memory entry cannot be found. !< subroutine get_from_memorylist(name, mem_path, mt, found, check) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - type(MemoryType), pointer, intent(inout) :: mt !< memory type entry - logical(LGP),intent(out) :: found !< set to .true. when found - logical(LGP), intent(in), optional :: check !< to suppress aborting the program when not found, - !! set check = .false. + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + type(MemoryType), pointer, intent(inout) :: mt !< memory type entry + logical(LGP), intent(out) :: found !< set to .true. when found + logical(LGP), intent(in), optional :: check !< to suppress aborting the program when not found, + !! set check = .false. ! -- local integer(I4B) :: ipos logical(LGP) check_opt @@ -279,7 +279,7 @@ subroutine get_from_memorylist(name, mem_path, mt, found, check) ! -- iterate over the memory list do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%path == mem_path) then + if (mt%name == name .and. mt%path == mem_path) then found = .true. exit end if @@ -290,9 +290,9 @@ subroutine get_from_memorylist(name, mem_path, mt, found, check) end if if (check_opt) then if (.not. found) then - errmsg = "Programming error in memory manager. Variable '" // & - trim(name) // "' in '" // trim(mem_path) // "' cannot be " // & - "assigned because it does not exist in memory manager." + errmsg = "Programming error in memory manager. Variable '"// & + trim(name)//"' in '"//trim(mem_path)//"' cannot be "// & + "assigned because it does not exist in memory manager." call store_error(errmsg, terminate=.TRUE.) end if end if @@ -300,39 +300,39 @@ subroutine get_from_memorylist(name, mem_path, mt, found, check) ! -- return return end subroutine get_from_memorylist - + !> @brief Issue allocation error message and stop program execution !< subroutine allocate_error(varname, mem_path, istat, isize) - character(len=*), intent(in) :: varname !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), intent(in) :: istat !< status code - integer(I4B), intent(in) :: isize !< size of allocation + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(in) :: istat !< status code + integer(I4B), intent(in) :: isize !< size of allocation ! -- local - character(len=20) :: csize - character(len=20) :: cstat + character(len=20) :: csize + character(len=20) :: cstat ! -- code ! ! -- initialize character variables - write(csize, '(i0)') isize - write(cstat, '(i0)') istat + write (csize, '(i0)') isize + write (cstat, '(i0)') istat ! ! -- create error message - errmsg = "Error trying to allocate memory. Path '" // trim(mem_path) // & - "' variable name '" // trim(varname) // "' size '" // trim(csize) // & - "'. Error message is '" // trim(adjustl(errmsg)) // & - "'. Status code is " // trim(cstat) // '.' + errmsg = "Error trying to allocate memory. Path '"//trim(mem_path)// & + "' variable name '"//trim(varname)//"' size '"//trim(csize)// & + "'. Error message is '"//trim(adjustl(errmsg))// & + "'. Status code is "//trim(cstat)//'.' ! ! -- store error and stop program execution call store_error(errmsg, terminate=.TRUE.) - end subroutine allocate_error + end subroutine allocate_error !> @brief Allocate a logical scalar !< subroutine allocate_logical(sclr, name, mem_path) - logical(LGP), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + logical(LGP), pointer, intent(inout) :: sclr !< variable for allocation + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local integer(I4B) :: istat type(MemoryType), pointer :: mt @@ -342,8 +342,8 @@ subroutine allocate_logical(sclr, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate the logical scalar - allocate(sclr, stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (sclr, stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if ! @@ -351,14 +351,14 @@ subroutine allocate_logical(sclr, name, mem_path) nvalues_alogical = nvalues_alogical + 1 ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%logicalsclr => sclr mt%isize = 1 mt%name = name mt%path = mem_path - write(mt%memtype, "(a)") 'LOGICAL' + write (mt%memtype, "(a)") 'LOGICAL' ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -370,10 +370,10 @@ end subroutine allocate_logical !> @brief Allocate a character string !< subroutine allocate_str(sclr, ilen, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length + integer(I4B), intent(in) :: ilen !< string length character(len=ilen), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local integer(I4B) :: istat type(MemoryType), pointer :: mt @@ -382,7 +382,7 @@ subroutine allocate_str(sclr, ilen, name, mem_path) ! ! -- make sure ilen is greater than 0 if (ilen < 1) then - errmsg = 'Programming error in allocate_str. ILEN must be greater than 0.' + errmsg = 'Programming error in allocate_str. ILEN must be greater than 0.' call store_error(errmsg, terminate=.TRUE.) end if ! @@ -390,7 +390,7 @@ subroutine allocate_str(sclr, ilen, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate string - allocate(character(len=ilen) :: sclr, stat=istat, errmsg=errmsg) + allocate (character(len=ilen) :: sclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if @@ -402,14 +402,14 @@ subroutine allocate_str(sclr, ilen, name, mem_path) nvalues_astr = nvalues_astr + ilen ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%strsclr => sclr mt%isize = ilen mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen + write (mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen ! ! -- add defined length string to the memory manager list call memorylist%add(mt) @@ -417,15 +417,16 @@ subroutine allocate_str(sclr, ilen, name, mem_path) ! -- return return end subroutine allocate_str - - !> @brief Allocate a 1-dimensional defined length string array + + !> @brief Allocate a 1-dimensional defined length string array !< subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length - character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr1d !< variable for allocation - integer(I4B), intent(in) :: nrow !< number of strings in array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(in) :: ilen !< string length + character(len=ilen), dimension(:), & + pointer, contiguous, intent(inout) :: astr1d !< variable for allocation + integer(I4B), intent(in) :: nrow !< number of strings in array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local variables type(MemoryType), pointer :: mt character(len=ilen) :: string @@ -439,8 +440,8 @@ subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path) ! ! -- make sure ilen is greater than 0 if (ilen < 1) then - errmsg = 'Programming error in allocate_str1d. ' // & - 'ILEN must be greater than 0.' + errmsg = 'Programming error in allocate_str1d. '// & + 'ILEN must be greater than 0.' call store_error(errmsg, terminate=.TRUE.) end if ! @@ -451,7 +452,7 @@ subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path) isize = ilen * nrow ! ! -- allocate defined length string array - allocate(character(len=ilen) :: astr1d(nrow), stat=istat, errmsg=errmsg) + allocate (character(len=ilen) :: astr1d(nrow), stat=istat, errmsg=errmsg) ! ! -- check for error condition if (istat /= 0) then @@ -467,14 +468,14 @@ subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path) nvalues_astr = nvalues_astr + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%astr1d => astr1d mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow ! ! -- add deferred length character array to the memory manager list call memorylist%add(mt) @@ -486,9 +487,9 @@ end subroutine allocate_str1d !> @brief Allocate a integer scalar !< subroutine allocate_int(sclr, name, mem_path) - integer(I4B), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), pointer, intent(inout) :: sclr !< variable for allocation + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -498,7 +499,7 @@ subroutine allocate_int(sclr, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate integer scalar - allocate(sclr, stat=istat, errmsg=errmsg) + allocate (sclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if @@ -507,14 +508,14 @@ subroutine allocate_int(sclr, name, mem_path) nvalues_aint = nvalues_aint + 1 ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%intsclr => sclr mt%isize = 1 mt%name = name mt%path = mem_path - write(mt%memtype, "(a)") 'INTEGER' + write (mt%memtype, "(a)") 'INTEGER' ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -522,14 +523,14 @@ subroutine allocate_int(sclr, name, mem_path) ! -- return return end subroutine allocate_int - + !> @brief Allocate a 1-dimensional integer array !< subroutine allocate_int1d(aint, nrow, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< variable for allocation - integer(I4B), intent(in) :: nrow !< integer array number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< variable for allocation + integer(I4B), intent(in) :: nrow !< integer array number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! --local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -543,7 +544,7 @@ subroutine allocate_int1d(aint, nrow, name, mem_path) isize = nrow ! ! -- allocate integer array - allocate(aint(nrow), stat=istat, errmsg=errmsg) + allocate (aint(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -552,14 +553,14 @@ subroutine allocate_int1d(aint, nrow, name, mem_path) nvalues_aint = nvalues_aint + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint1d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -567,15 +568,15 @@ subroutine allocate_int1d(aint, nrow, name, mem_path) ! -- return return end subroutine allocate_int1d - + !> @brief Allocate a 2-dimensional integer array !< subroutine allocate_int2d(aint, ncol, nrow, name, mem_path) - integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -589,7 +590,7 @@ subroutine allocate_int2d(aint, ncol, nrow, name, mem_path) isize = ncol * nrow ! ! -- allocate the integer array - allocate(aint(ncol, nrow), stat=istat, errmsg=errmsg) + allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -598,30 +599,30 @@ subroutine allocate_int2d(aint, ncol, nrow, name, mem_path) nvalues_aint = nvalues_aint + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint2d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! ! -- add memory type to the memory list call memorylist%add(mt) ! ! -- return end subroutine allocate_int2d - + !> @brief Allocate a 3-dimensional integer array !< subroutine allocate_int3d(aint, ncol, nrow, nlay, name, mem_path) - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - integer(I4B), intent(in) :: nlay !< number of layers - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + integer(I4B), intent(in) :: nlay !< number of layers + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -635,24 +636,24 @@ subroutine allocate_int3d(aint, ncol, nrow, nlay, name, mem_path) isize = ncol * nrow * nlay ! ! -- allocate integer array - allocate(aint(ncol, nrow, nlay), stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (aint(ncol, nrow, nlay), stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if ! - ! -- update counter + ! -- update counter nvalues_aint = nvalues_aint + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint3d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & - nrow, nlay + write (mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & + nrow, nlay ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -664,9 +665,9 @@ end subroutine allocate_int3d !> @brief Allocate a real scalar !< subroutine allocate_dbl(sclr, name, mem_path) - real(DP), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), pointer, intent(inout) :: sclr !< variable for allocation + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -676,7 +677,7 @@ subroutine allocate_dbl(sclr, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate real scalar - allocate(sclr, stat=istat, errmsg=errmsg) + allocate (sclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if @@ -685,14 +686,14 @@ subroutine allocate_dbl(sclr, name, mem_path) nvalues_aint = nvalues_aint + 1 ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%dblsclr => sclr mt%isize = 1 mt%name = name mt%path = mem_path - write(mt%memtype, "(a)") 'DOUBLE' + write (mt%memtype, "(a)") 'DOUBLE' ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -700,14 +701,14 @@ subroutine allocate_dbl(sclr, name, mem_path) ! -- return return end subroutine allocate_dbl - + !> @brief Allocate a 1-dimensional real array !< subroutine allocate_dbl1d(adbl, nrow, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< variable for allocation - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< variable for allocation + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -721,7 +722,7 @@ subroutine allocate_dbl1d(adbl, nrow, name, mem_path) isize = nrow ! ! -- allocate the real array - allocate(adbl(nrow), stat=istat, errmsg=errmsg) + allocate (adbl(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -730,14 +731,14 @@ subroutine allocate_dbl1d(adbl, nrow, name, mem_path) nvalues_adbl = nvalues_adbl + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl1d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -745,15 +746,15 @@ subroutine allocate_dbl1d(adbl, nrow, name, mem_path) ! -- return return end subroutine allocate_dbl1d - + !> @brief Allocate a 2-dimensional real array !< subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -767,7 +768,7 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) isize = ncol * nrow ! ! -- allocate the real array - allocate(adbl(ncol, nrow), stat=istat, errmsg=errmsg) + allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -776,14 +777,14 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) nvalues_adbl = nvalues_adbl + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl2d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -791,16 +792,16 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) ! -- return return end subroutine allocate_dbl2d - + !> @brief Allocate a 3-dimensional real array !< subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) - real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - integer(I4B), intent(in) :: nlay !< number of layers - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + integer(I4B), intent(in) :: nlay !< number of layers + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -814,7 +815,7 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) isize = ncol * nrow * nlay ! ! -- allocate the real array - allocate(adbl(ncol, nrow, nlay), stat=istat, errmsg=errmsg) + allocate (adbl(ncol, nrow, nlay), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -823,15 +824,15 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) nvalues_adbl = nvalues_adbl + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl3d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & - nrow, nlay + write (mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & + nrow, nlay ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -839,15 +840,15 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) ! -- return return end subroutine allocate_dbl3d - + !> @brief Check in an existing 1d integer array with a new address (name + path) !< subroutine checkin_int1d(aint, name, mem_path, name2, mem_path2) integer(I4B), dimension(:), pointer, contiguous, intent(in) :: aint !< the existing array - character(len=*), intent(in) :: name !< new variable name - character(len=*), intent(in) :: mem_path !< new path where variable is stored - character(len=*), intent(in) :: name2 !< existing variable name - character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored + character(len=*), intent(in) :: name !< new variable name + character(len=*), intent(in) :: mem_path !< new path where variable is stored + character(len=*), intent(in) :: name2 !< existing variable name + character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored ! --local type(MemoryType), pointer :: mt integer(I4B) :: isize @@ -860,14 +861,14 @@ subroutine checkin_int1d(aint, name, mem_path, name2, mem_path2) isize = size(aint) ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint1d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize ! ! -- set master information mt%master = .false. @@ -884,11 +885,11 @@ end subroutine checkin_int1d !> @brief Check in an existing 1d double precision array with a new address (name + path) !< subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the existing array - character(len=*), intent(in) :: name !< new variable name - character(len=*), intent(in) :: mem_path !< new path where variable is stored - character(len=*), intent(in) :: name2 !< existing variable name - character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the existing array + character(len=*), intent(in) :: name !< new variable name + character(len=*), intent(in) :: mem_path !< new path where variable is stored + character(len=*), intent(in) :: name2 !< existing variable name + character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: isize @@ -901,14 +902,14 @@ subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2) isize = size(adbl) ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl1d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! ! -- set master information mt%master = .false. @@ -921,15 +922,15 @@ subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2) ! -- return return end subroutine checkin_dbl1d - + !> @brief Reallocate a 1-dimensional defined length string array !< subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length - integer(I4B), intent(in) :: nrow !< number of rows + integer(I4B), intent(in) :: ilen !< string length + integer(I4B), intent(in) :: nrow !< number of rows character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reallocated string array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -956,7 +957,7 @@ subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) isize = ilen * nrow ! ! -- allocate astrtemp - allocate(astrtemp(nrow), stat=istat, errmsg=errmsg) + allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -972,46 +973,46 @@ subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(astr) + deallocate (astr) ! ! -- allocate astr1d - allocate(astr(nrow), stat=istat, errmsg=errmsg) + allocate (astr(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if ! ! -- fill the reallocate character array do n = 1, nrow - astr(n) = astrtemp(n) + astr(n) = astrtemp(n) end do ! ! -- deallocate temporary storage - deallocate(astrtemp) + deallocate (astrtemp) ! ! -- reset memory manager values mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_astr = nvalues_astr + isize - isize_old - write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow else - errmsg = "Programming error, varible '" // trim(name) // "' from '" // & - trim(mem_path) // "' is not defined in the memory manager. Use " // & - "mem_allocate instead." + errmsg = "Programming error, varible '"//trim(name)//"' from '"// & + trim(mem_path)//"' is not defined in the memory manager. Use "// & + "mem_allocate instead." call store_error(errmsg, terminate=.TRUE.) end if ! ! -- return return end subroutine reallocate_str1d - + !> @brief Reallocate a 1-dimensional integer array !< subroutine reallocate_int1d(aint, nrow, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1029,16 +1030,16 @@ subroutine reallocate_int1d(aint, nrow, name, mem_path) isize = nrow isizeold = size(mt%aint1d) ifill = min(isizeold, isize) - allocate(aint(nrow), stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (aint(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ifill aint(i) = mt%aint1d(i) - enddo + end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%aint1d) + deallocate (mt%aint1d) mt%aint1d => aint mt%isize = isize mt%nrealloc = mt%nrealloc + 1 @@ -1048,15 +1049,15 @@ subroutine reallocate_int1d(aint, nrow, name, mem_path) ! -- return return end subroutine reallocate_int1d - + !> @brief Reallocate a 2-dimensional integer array !< subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reallocated 2d integer array - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1075,36 +1076,36 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) ishape = shape(mt%aint2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate(aint(ncol, nrow), stat=istat, errmsg=errmsg) + allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ishape(2) do j = 1, ishape(1) aint(j, i) = mt%aint2d(j, i) - enddo - enddo + end do + end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%aint2d) + deallocate (mt%aint2d) mt%aint2d => aint mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_aint = nvalues_aint + isize - isizeold - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! ! -- return return end subroutine reallocate_int2d - + !> @brief Reallocate a 1-dimensional real array !< subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -1122,35 +1123,35 @@ subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) isize = nrow isizeold = size(mt%adbl1d) ifill = min(isizeold, isize) - allocate(adbl(nrow), stat=istat, errmsg=errmsg) + allocate (adbl(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ifill adbl(i) = mt%adbl1d(i) - enddo + end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%adbl1d) + deallocate (mt%adbl1d) mt%adbl1d => adbl mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! ! -- return return end subroutine reallocate_dbl1d - + !> @brief Reallocate a 2-dimensional real array !< subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reallocated 2d real array - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1169,8 +1170,8 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) ishape = shape(mt%adbl2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate(adbl(ncol, nrow), stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ishape(2) @@ -1180,165 +1181,165 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%adbl2d) + deallocate (mt%adbl2d) mt%adbl2d => adbl mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! ! -- return return end subroutine reallocate_dbl2d - + !> @brief Set pointer to a logical scalar !< subroutine setptr_logical(sclr, name, mem_path) - logical(LGP), pointer, intent(inout) :: sclr !< pointer to logical scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), pointer, intent(inout) :: sclr !< pointer to logical scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) sclr => mt%logicalsclr ! ! -- return return end subroutine setptr_logical - + !> @brief Set pointer to integer scalar !< subroutine setptr_int(sclr, name, mem_path) - integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) sclr => mt%intsclr ! ! -- return return end subroutine setptr_int - + !> @brief Set pointer to 1d integer array !< subroutine setptr_int1d(aint, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => mt%aint1d ! ! -- return return end subroutine setptr_int1d - + !> @brief Set pointer to 2d integer array !< subroutine setptr_int2d(aint, name, mem_path) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => mt%aint2d ! ! -- return return end subroutine setptr_int2d - + !> @brief Set pointer to 3d integer array !< subroutine setptr_int3d(aint, name, mem_path) integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< pointer to 3d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => mt%aint3d ! ! -- return return end subroutine setptr_int3d - + !> @brief Set pointer to a real scalar !< subroutine setptr_dbl(sclr, name, mem_path) - real(DP), pointer, intent(inout) :: sclr !< pointer to a real scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), pointer, intent(inout) :: sclr !< pointer to a real scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) sclr => mt%dblsclr ! ! -- return return end subroutine setptr_dbl - + !> @brief Set pointer to a 1d real array !< subroutine setptr_dbl1d(adbl, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => mt%adbl1d ! ! -- return return end subroutine setptr_dbl1d - + !> @brief Set pointer to a 2d real array !< subroutine setptr_dbl2d(adbl, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => mt%adbl2d ! ! -- return return end subroutine setptr_dbl2d - - !> @brief Set pointer to a 3d real array + + !> @brief Set pointer to a 3d real array !< subroutine setptr_dbl3d(adbl, name, mem_path) real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 3d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => mt%adbl3d ! ! -- return @@ -1348,25 +1349,25 @@ end subroutine setptr_dbl3d !> @brief Make a copy of a 1-dimensional integer array !< subroutine copyptr_int1d(aint, name, mem_path, mem_path_copy) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< returned copy of 1d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< returned copy of 1d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found integer(I4B) :: n ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => null() ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_int1d(aint, size(mt%aint1d), mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(aint(size(mt%aint1d))) + allocate (aint(size(mt%aint1d))) end if do n = 1, size(mt%aint1d) aint(n) = mt%aint1d(n) @@ -1379,12 +1380,12 @@ end subroutine copyptr_int1d !> @brief Make a copy of a 2-dimensional integer array !< subroutine copyptr_int2d(aint, name, mem_path, mem_path_copy) - integer(I4B), dimension(:,:), pointer, contiguous, intent(inout) :: aint !< returned copy of 2d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< returned copy of 2d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1393,20 +1394,20 @@ subroutine copyptr_int2d(aint, name, mem_path, mem_path_copy) integer(I4B) :: ncol integer(I4B) :: nrow ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => null() ncol = size(mt%aint2d, dim=1) nrow = size(mt%aint2d, dim=2) ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_int2d(aint, ncol, nrow, mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(aint(ncol,nrow)) + allocate (aint(ncol, nrow)) end if do i = 1, nrow do j = 1, ncol - aint(j,i) = mt%aint2d(j,i) + aint(j, i) = mt%aint2d(j, i) end do end do ! @@ -1417,25 +1418,25 @@ end subroutine copyptr_int2d !> @brief Make a copy of a 1-dimensional real array !< subroutine copyptr_dbl1d(adbl, name, mem_path, mem_path_copy) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 1d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 1d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found integer(I4B) :: n ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => null() ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_dbl1d(adbl, size(mt%adbl1d), mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(adbl(size(mt%adbl1d))) + allocate (adbl(size(mt%adbl1d))) end if do n = 1, size(mt%adbl1d) adbl(n) = mt%adbl1d(n) @@ -1448,12 +1449,12 @@ end subroutine copyptr_dbl1d !> @brief Make a copy of a 2-dimensional real array !< subroutine copyptr_dbl2d(adbl, name, mem_path, mem_path_copy) - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 2d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< returned copy of 2d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1462,33 +1463,33 @@ subroutine copyptr_dbl2d(adbl, name, mem_path, mem_path_copy) integer(I4B) :: ncol integer(I4B) :: nrow ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => null() ncol = size(mt%adbl2d, dim=1) nrow = size(mt%adbl2d, dim=2) ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_dbl2d(adbl, ncol, nrow, mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(adbl(ncol,nrow)) + allocate (adbl(ncol, nrow)) end if do i = 1, nrow do j = 1, ncol - adbl(j,i) = mt%adbl2d(j,i) + adbl(j, i) = mt%adbl2d(j, i) end do end do ! ! -- return return end subroutine copyptr_dbl2d - + !> @brief Copy values from a 1-dimensional real array in the memory !< manager to a passed 1-dimensional real array subroutine copy_dbl1d(adbl, name, mem_path) real(DP), dimension(:), intent(inout) :: adbl !< target array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1502,15 +1503,15 @@ subroutine copy_dbl1d(adbl, name, mem_path) ! -- return return end subroutine copy_dbl1d - - !> @brief Set the pointer for an integer scalar to + + !> @brief Set the pointer for an integer scalar to !< a target array already stored in the memory manager subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target) - integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1520,12 +1521,12 @@ subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (associated(sclr)) then nvalues_aint = nvalues_aint - 1 - deallocate(sclr) + deallocate (sclr) end if sclr => mt2%intsclr mt%intsclr => sclr - mt%isize = 1 - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize + mt%isize = 1 + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize ! ! -- set master information mt%master = .false. @@ -1536,14 +1537,14 @@ subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_int - !> @brief Set the pointer for a 1-dimensional integer array to + !> @brief Set the pointer for a 1-dimensional integer array to !< a target array already stored in the memory manager subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1553,12 +1554,12 @@ subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(aint) > 0) then nvalues_aint = nvalues_aint - size(aint) - deallocate(aint) + deallocate (aint) end if aint => mt2%aint1d mt%aint1d => aint - mt%isize = size(aint) - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize + mt%isize = size(aint) + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize ! ! -- set master information mt%master = .false. @@ -1569,14 +1570,14 @@ subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_int1d - !> @brief Set the pointer for a 2-dimensional integer array to + !> @brief Set the pointer for a 2-dimensional integer array to !< a target array already stored in the memory manager subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target) - integer(I4B), dimension(:,:), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1588,14 +1589,14 @@ subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(aint) > 0) then nvalues_aint = nvalues_aint - size(aint) - deallocate(aint) + deallocate (aint) end if aint => mt2%aint2d mt%aint2d => aint mt%isize = size(aint) ncol = size(aint, dim=1) nrow = size(aint, dim=2) - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! ! -- set master information mt%master = .false. @@ -1606,14 +1607,14 @@ subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_int2d - !> @brief Set the pointer for a 1-dimensional real array to + !> @brief Set the pointer for a 1-dimensional real array to !< a target array already stored in the memory manager subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1623,12 +1624,12 @@ subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(adbl) > 0) then nvalues_adbl = nvalues_adbl - size(adbl) - deallocate(adbl) + deallocate (adbl) end if adbl => mt2%adbl1d mt%adbl1d => adbl - mt%isize = size(adbl) - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize + mt%isize = size(adbl) + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize ! ! -- set master information mt%master = .false. @@ -1639,14 +1640,14 @@ subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_dbl1d - !> @brief Set the pointer for a 2-dimensional real array to + !> @brief Set the pointer for a 2-dimensional real array to !< a target array already stored in the memory manager subroutine reassignptr_dbl2d(adbl, name, mem_path, name_target, mem_path_target) - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1658,14 +1659,14 @@ subroutine reassignptr_dbl2d(adbl, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(adbl) > 0) then nvalues_adbl = nvalues_adbl - size(adbl) - deallocate(adbl) + deallocate (adbl) end if adbl => mt2%adbl2d mt%adbl2d => adbl mt%isize = size(adbl) ncol = size(adbl, dim=1) nrow = size(adbl, dim=2) - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! ! -- set master information mt%master = .false. @@ -1679,9 +1680,9 @@ end subroutine reassignptr_dbl2d !> @brief Deallocate a variable-length character string !< subroutine deallocate_str(sclr, name, mem_path) - character(len=*), pointer, intent(inout) :: sclr !< pointer to string - character(len=*), intent(in), optional :: name !< variable name - character(len=*), intent(in), optional :: mem_path !< path where variable is stored + character(len=*), pointer, intent(inout) :: sclr !< pointer to string + character(len=*), intent(in), optional :: name !< variable name + character(len=*), intent(in), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1689,13 +1690,13 @@ subroutine deallocate_str(sclr, name, mem_path) ! -- code if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%strsclr) + nullify (mt%strsclr) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) if (associated(mt%strsclr, sclr)) then - nullify(mt%strsclr) + nullify (mt%strsclr) found = .true. exit end if @@ -1705,24 +1706,24 @@ subroutine deallocate_str(sclr, name, mem_path) call store_error('Programming error in deallocate_str.', terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else - nullify(sclr) + nullify (sclr) end if end if ! ! -- return return end subroutine deallocate_str - + !> @brief Deallocate an array of variable-length character strings !! !! @todo confirm this description versus the previous doc !< subroutine deallocate_str1d(astr1d, name, mem_path) character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d !< array of strings - character(len=*), optional, intent(in) :: name !< variable name - character(len=*), optional, intent(in) :: mem_path !< path where variable is stored + character(len=*), optional, intent(in) :: name !< variable name + character(len=*), optional, intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1732,25 +1733,25 @@ subroutine deallocate_str1d(astr1d, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%astr1d) + nullify (mt%astr1d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) if (associated(mt%astr1d, astr1d)) then - nullify(mt%astr1d) + nullify (mt%astr1d) found = .true. exit end if end do end if - if (.not. found .and. size(astr1d) > 0 ) then + if (.not. found .and. size(astr1d) > 0) then call store_error('programming error in deallocate_str1d', terminate=.TRUE.) else if (mt%master) then - deallocate(astr1d) + deallocate (astr1d) else - nullify(astr1d) + nullify (astr1d) end if end if ! @@ -1761,7 +1762,7 @@ end subroutine deallocate_str1d !> @brief Deallocate a logical scalar !< subroutine deallocate_logical(sclr) - logical(LGP), pointer, intent(inout) :: sclr !< logical scalar to deallocate + logical(LGP), pointer, intent(inout) :: sclr !< logical scalar to deallocate ! -- local class(MemoryType), pointer :: mt logical(LGP) :: found @@ -1770,30 +1771,31 @@ subroutine deallocate_logical(sclr) found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%logicalsclr, sclr)) then - nullify(mt%logicalsclr) + if (associated(mt%logicalsclr, sclr)) then + nullify (mt%logicalsclr) found = .true. exit end if end do if (.not. found) then - call store_error('programming error in deallocate_logical', terminate=.TRUE.) + call store_error('programming error in deallocate_logical', & + terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else - nullify(sclr) + nullify (sclr) end if end if ! ! -- return return end subroutine deallocate_logical - + !> @brief Deallocate a integer scalar !< subroutine deallocate_int(sclr) - integer(I4B), pointer, intent(inout) :: sclr !< integer variable to deallocate + integer(I4B), pointer, intent(inout) :: sclr !< integer variable to deallocate ! -- local class(MemoryType), pointer :: mt logical(LGP) :: found @@ -1802,8 +1804,8 @@ subroutine deallocate_int(sclr) found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%intsclr, sclr)) then - nullify(mt%intsclr) + if (associated(mt%intsclr, sclr)) then + nullify (mt%intsclr) found = .true. exit end if @@ -1812,20 +1814,20 @@ subroutine deallocate_int(sclr) call store_error('Programming error in deallocate_int.', terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else - nullify(sclr) + nullify (sclr) end if end if ! ! -- return return end subroutine deallocate_int - + !> @brief Deallocate a real scalar !< subroutine deallocate_dbl(sclr) - real(DP), pointer, intent(inout) :: sclr !< real variable to deallocate + real(DP), pointer, intent(inout) :: sclr !< real variable to deallocate ! -- local class(MemoryType), pointer :: mt logical(LGP) :: found @@ -1834,8 +1836,8 @@ subroutine deallocate_dbl(sclr) found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%dblsclr, sclr)) then - nullify(mt%dblsclr) + if (associated(mt%dblsclr, sclr)) then + nullify (mt%dblsclr) found = .true. exit end if @@ -1844,7 +1846,7 @@ subroutine deallocate_dbl(sclr) call store_error('Programming error in deallocate_dbl.', terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else nullify (sclr) end if @@ -1853,13 +1855,13 @@ subroutine deallocate_dbl(sclr) ! -- return return end subroutine deallocate_dbl - + !> @brief Deallocate a 1-dimensional integer array !< subroutine deallocate_int1d(aint, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< 1d integer array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< 1d integer array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1869,38 +1871,38 @@ subroutine deallocate_int1d(aint, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%aint1d) + nullify (mt%aint1d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) if (associated(mt%aint1d, aint)) then - nullify(mt%aint1d) + nullify (mt%aint1d) found = .true. exit end if end do end if - if (.not. found .and. size(aint) > 0 ) then + if (.not. found .and. size(aint) > 0) then call store_error('programming error in deallocate_int1d', terminate=.TRUE.) else if (mt%master) then - deallocate(aint) + deallocate (aint) else - nullify(aint) + nullify (aint) end if end if ! ! -- return return end subroutine deallocate_int1d - + !> @brief Deallocate a 2-dimensional integer array !< subroutine deallocate_int2d(aint, name, mem_path) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< 2d integer array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1910,38 +1912,38 @@ subroutine deallocate_int2d(aint, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%aint2d) + nullify (mt%aint2d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint2d, aint)) then - nullify(mt%aint2d) + if (associated(mt%aint2d, aint)) then + nullify (mt%aint2d) found = .true. exit end if end do end if - if (.not. found .and. size(aint) > 0 ) then + if (.not. found .and. size(aint) > 0) then call store_error('programming error in deallocate_int2d', terminate=.TRUE.) else if (mt%master) then - deallocate(aint) + deallocate (aint) else - nullify(aint) + nullify (aint) end if end if ! ! -- return return end subroutine deallocate_int2d - + !> @brief Deallocate a 3-dimensional integer array !< subroutine deallocate_int3d(aint, name, mem_path) - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< 3d integer array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< 3d integer array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1951,38 +1953,38 @@ subroutine deallocate_int3d(aint, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%aint3d) + nullify (mt%aint3d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint3d, aint)) then - nullify(mt%aint3d) + if (associated(mt%aint3d, aint)) then + nullify (mt%aint3d) found = .true. exit end if end do end if - if (.not. found .and. size(aint) > 0 ) then + if (.not. found .and. size(aint) > 0) then call store_error('programming error in deallocate_int3d', terminate=.TRUE.) else if (mt%master) then - deallocate(aint) + deallocate (aint) else - nullify(aint) + nullify (aint) end if end if ! ! -- return return end subroutine deallocate_int3d - + !> @brief Deallocate a 1-dimensional real array !< subroutine deallocate_dbl1d(adbl, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< 1d real array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< 1d real array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1992,38 +1994,38 @@ subroutine deallocate_dbl1d(adbl, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%adbl1d) + nullify (mt%adbl1d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl1d, adbl)) then - nullify(mt%adbl1d) + if (associated(mt%adbl1d, adbl)) then + nullify (mt%adbl1d) found = .true. exit end if end do end if - if (.not. found .and. size(adbl) > 0 ) then + if (.not. found .and. size(adbl) > 0) then call store_error('programming error in deallocate_dbl1d', terminate=.TRUE.) else if (mt%master) then - deallocate(adbl) + deallocate (adbl) else - nullify(adbl) + nullify (adbl) end if end if ! ! -- return return end subroutine deallocate_dbl1d - + !> @brief Deallocate a 2-dimensional real array !< subroutine deallocate_dbl2d(adbl, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< 2d real array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -2033,38 +2035,38 @@ subroutine deallocate_dbl2d(adbl, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%adbl2d) + nullify (mt%adbl2d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl2d, adbl)) then - nullify(mt%adbl2d) + if (associated(mt%adbl2d, adbl)) then + nullify (mt%adbl2d) found = .true. exit end if end do end if - if (.not. found .and. size(adbl) > 0 ) then + if (.not. found .and. size(adbl) > 0) then call store_error('programming error in deallocate_dbl2d', terminate=.TRUE.) else if (mt%master) then - deallocate(adbl) + deallocate (adbl) else - nullify(adbl) + nullify (adbl) end if end if ! ! -- return return end subroutine deallocate_dbl2d - + !> @brief Deallocate a 3-dimensional real array !< subroutine deallocate_dbl3d(adbl, name, mem_path) - real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< 3d real array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< 3d real array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -2074,25 +2076,25 @@ subroutine deallocate_dbl3d(adbl, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%adbl3d) + nullify (mt%adbl3d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl3d, adbl)) then - nullify(mt%adbl3d) + if (associated(mt%adbl3d, adbl)) then + nullify (mt%adbl3d) found = .true. exit end if end do end if - if (.not. found .and. size(adbl) > 0 ) then + if (.not. found .and. size(adbl) > 0) then call store_error('programming error in deallocate_dbl3d', terminate=.TRUE.) else if (mt%master) then - deallocate(adbl) + deallocate (adbl) else - nullify(adbl) + nullify (adbl) end if end if ! @@ -2103,37 +2105,37 @@ end subroutine deallocate_dbl3d !> @brief Set the memory print option !< subroutine mem_set_print_option(iout, keyword, error_msg) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - character(len=*), intent(in) :: keyword !< memory print option - character(len=*), intent(inout) :: error_msg !< returned error message if keyword is not valid option + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + character(len=*), intent(in) :: keyword !< memory print option + character(len=*), intent(inout) :: error_msg !< returned error message if keyword is not valid option ! -- local ! -- format ! -- code select case (keyword) - case ('NONE') - iprmem = 0 - write(iout, '(4x, a)') & - 'LIMITED MEMORY INFORMATION WILL BE WRITTEN.' - case ('SUMMARY') - iprmem = 1 - write(iout, '(4x, a)') & - 'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' - case ('ALL') - iprmem = 2 - write(iout, '(4x, a)') & - 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' - case default - error_msg = "Unknown memory print option '" // trim(keyword) // "." + case ('NONE') + iprmem = 0 + write (iout, '(4x, a)') & + 'LIMITED MEMORY INFORMATION WILL BE WRITTEN.' + case ('SUMMARY') + iprmem = 1 + write (iout, '(4x, a)') & + 'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' + case ('ALL') + iprmem = 2 + write (iout, '(4x, a)') & + 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' + case default + error_msg = "Unknown memory print option '"//trim(keyword)//"." end select return end subroutine mem_set_print_option - + !> @brief Create a table if memory_print_option is 'SUMMARY' !< subroutine mem_summary_table(iout, nrows, cunits) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - integer(I4B), intent(in) :: nrows !< number of table rows - character(len=*), intent(in) :: cunits !< memory units (bytes, kilobytes, megabytes, or gigabytes) + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + integer(I4B), intent(in) :: nrows !< number of table rows + character(len=*), intent(in) :: cunits !< memory units (bytes, kilobytes, megabytes, or gigabytes) ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -2143,8 +2145,8 @@ subroutine mem_summary_table(iout, nrows, cunits) nterms = 6 ! ! -- set up table title - title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER, ' // & - 'IN ' // trim(cunits) + title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER, '// & + 'IN '//trim(cunits) ! ! -- set up stage tableobj call table_cr(memtab, 'MEM SUM', title) @@ -2176,13 +2178,13 @@ subroutine mem_summary_table(iout, nrows, cunits) ! ! -- return return - end subroutine mem_summary_table - - !> @brief Create a table if memory_print_option is 'ALL' + end subroutine mem_summary_table + + !> @brief Create a table if memory_print_option is 'ALL' !< subroutine mem_detailed_table(iout, nrows) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - integer(I4B), intent(in) :: nrows !< number of table rows + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + integer(I4B), intent(in) :: nrows !< number of table rows ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -2220,17 +2222,17 @@ subroutine mem_detailed_table(iout, nrows) ! ! -- return return - end subroutine mem_detailed_table - + end subroutine mem_detailed_table + !> @brief Write a row for the memory_print_option 'SUMMARY' table !< subroutine mem_summary_line(component, rchars, rlog, rint, rreal, bytes) character(len=*), intent(in) :: component !< character defining the program component (e.g. solution) - real(DP), intent(in) :: rchars !< allocated size of characters (in common units) - real(DP), intent(in) :: rlog !< allocated size of logical (in common units) - real(DP), intent(in) :: rint !< allocated size of integer variables (in common units) - real(DP), intent(in) :: rreal !< allocated size of real variables (in common units) - real(DP), intent(in) :: bytes !< total allocated memory in memory manager (in common units) + real(DP), intent(in) :: rchars !< allocated size of characters (in common units) + real(DP), intent(in) :: rlog !< allocated size of logical (in common units) + real(DP), intent(in) :: rint !< allocated size of integer variables (in common units) + real(DP), intent(in) :: rreal !< allocated size of real variables (in common units) + real(DP), intent(in) :: bytes !< total allocated memory in memory manager (in common units) ! -- formats ! -- code ! @@ -2244,14 +2246,14 @@ subroutine mem_summary_line(component, rchars, rlog, rint, rreal, bytes) ! ! -- return return - end subroutine mem_summary_line + end subroutine mem_summary_line !> @brief Determine appropriate memory unit and conversion factor !< subroutine mem_units(bytes, fact, cunits) ! -- dummy - real(DP), intent(in) :: bytes !< total nr. of bytes - real(DP), intent(inout) :: fact !< conversion factor + real(DP), intent(in) :: bytes !< total nr. of bytes + real(DP), intent(inout) :: fact !< conversion factor character(len=*), intent(inout) :: cunits !< string with memory unit ! -- local ! -- formats @@ -2271,20 +2273,20 @@ subroutine mem_units(bytes, fact, cunits) else if (bytes < DEP9) then fact = DEM6 cunits = 'MEGABYTES' - else + else fact = DEM9 cunits = 'GIGABYTES' end if ! ! -- return return - end subroutine mem_units - - !> @brief Create and fill a table with the total allocated memory + end subroutine mem_units + + !> @brief Create and fill a table with the total allocated memory !< in the memory manager subroutine mem_summary_total(iout, bytes) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - real(DP), intent(in) :: bytes !< total number of bytes allocated in the memory manager + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + real(DP), intent(in) :: bytes !< total number of bytes allocated in the memory manager ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -2304,7 +2306,7 @@ subroutine mem_summary_total(iout, bytes) nrows = 5 ! ! -- set up table title - title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE, IN ' // trim(cunits) + title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE, IN '//trim(cunits) ! ! -- set up stage tableobj call table_cr(memtab, 'MEM TOT', title) @@ -2351,8 +2353,8 @@ subroutine mem_summary_total(iout, bytes) ! ! -- return return - end subroutine mem_summary_total - + end subroutine mem_summary_total + !> @brief Generic function to clean a memory manager table !< subroutine mem_cleanup_table() @@ -2360,21 +2362,21 @@ subroutine mem_cleanup_table() ! -- formats ! -- code call memtab%table_da() - deallocate(memtab) - nullify(memtab) + deallocate (memtab) + nullify (memtab) ! ! -- return return - end subroutine mem_cleanup_table - - !> @brief Write memory manager memory usage based on the + end subroutine mem_cleanup_table + + !> @brief Write memory manager memory usage based on the !! user-specified memory_print_option !! !! The total memory usage by data types (int, real, etc.) !! is written for every simulation. !< subroutine mem_write_usage(iout) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst ! -- local class(MemoryType), pointer :: mt character(len=LENMEMPATH), allocatable, dimension(:) :: cunique @@ -2397,9 +2399,9 @@ subroutine mem_write_usage(iout) ! -- code ! ! -- Calculate simulation memory allocation - simbytes = (nvalues_astr + & - nvalues_alogical * LGP + & - nvalues_aint * I4B + & + simbytes = (nvalues_astr + & + nvalues_alogical * LGP + & + nvalues_aint * I4B + & nvalues_adbl * DP) simbytes = real(simbytes, DP) ! @@ -2465,7 +2467,7 @@ subroutine mem_write_usage(iout) ! -- return return end subroutine mem_write_usage - + !> @brief Deallocate memory in the memory manager !< subroutine mem_da() @@ -2484,8 +2486,8 @@ subroutine mem_da() ! ! -- check if memory has been deallocated if (mt%mt_associated() .and. mt%isize > 0) then - error_msg = trim(adjustl(mt%path)) // ' ' // & - trim(adjustl(mt%name)) // ' not deallocated' + error_msg = trim(adjustl(mt%path))//' '// & + trim(adjustl(mt%name))//' not deallocated' call store_error(trim(error_msg)) end if ! @@ -2493,15 +2495,15 @@ subroutine mem_da() ucname = mt%name call UPCASE(ucname) if (mt%name /= ucname) then - error_msg = trim(adjustl(mt%path)) // ' ' // & - trim(adjustl(mt%name)) // ' not upper case' + error_msg = trim(adjustl(mt%path))//' '// & + trim(adjustl(mt%name))//' not upper case' call store_error(trim(error_msg)) end if end if ! ! -- deallocate instance of memory type - deallocate(mt) - enddo + deallocate (mt) + end do call memorylist%clear() if (count_errors() > 0) then call store_error('Could not clear memory list.', terminate=.TRUE.) @@ -2510,7 +2512,7 @@ subroutine mem_da() ! -- return return end subroutine mem_da - + !> @brief Create a array with unique first components from all memory paths. !! Only the first component of the memory path is evaluated. !< @@ -2518,7 +2520,7 @@ subroutine mem_unique_origins(cunique) ! -- modules use ArrayHandlersModule, only: ExpandArray, ifind ! -- dummy - character(len=LENMEMPATH), allocatable, dimension(:), intent(inout) :: cunique !< array with unique first components + character(len=LENMEMPATH), allocatable, dimension(:), intent(inout) :: cunique !< array with unique first components ! -- local class(MemoryType), pointer :: mt character(len=LENCOMPONENTNAME) :: component @@ -2528,14 +2530,14 @@ subroutine mem_unique_origins(cunique) ! -- code ! ! -- initialize cunique - allocate(cunique(0)) + allocate (cunique(0)) ! ! -- find unique origins do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) call split_mem_path(mt%path, component, subcomponent) ipa = ifind(cunique, component) - if(ipa < 1) then + if (ipa < 1) then call ExpandArray(cunique, 1) cunique(size(cunique)) = component end if @@ -2544,5 +2546,5 @@ subroutine mem_unique_origins(cunique) ! -- return return end subroutine mem_unique_origins - + end module MemoryManagerModule diff --git a/src/Utilities/Memory/MemorySetHandler.f90 b/src/Utilities/Memory/MemorySetHandler.f90 index c1756ec79c8..a9af706373b 100644 --- a/src/Utilities/Memory/MemorySetHandler.f90 +++ b/src/Utilities/Memory/MemorySetHandler.f90 @@ -1,6 +1,6 @@ -module MemorySetHandlerModule - use KindModule, only: I4B, LGP - use ListModule, only: ListType +module MemorySetHandlerModule + use KindModule, only: I4B, LGP + use ListModule, only: ListType use MemoryTypeModule, only: MemoryType use MemoryManagerModule, only: get_from_memorylist use ConstantsModule, only: LENMEMPATH, LENVARNAME @@ -27,20 +27,20 @@ subroutine set_handler_iface(owner, status) end subroutine end interface - contains +contains !> @brief Register the event handler and context for this variable !! !! The event handler and its ctx are called whenever the trigger - !! is given by calling @p on_set_memory(). This allows to handle - !! side effects, e.g. when a variable is from outside a class + !! is given by calling @p on_set_memory(). This allows to handle + !! side effects, e.g. when a variable is from outside a class !! (the context) such as happens with the BMI. !< subroutine mem_register_handler(var_name, mem_path, handler, ctx) - character(len=*), intent(in) :: var_name !< the variable name - character(len=*), intent(in) :: mem_path !< the memory path - procedure(set_handler_iface), pointer :: handler !< called after memory is set - class(*), pointer :: ctx !< the context with which the handler should be called + character(len=*), intent(in) :: var_name !< the variable name + character(len=*), intent(in) :: mem_path !< the memory path + procedure(set_handler_iface), pointer :: handler !< called after memory is set + class(*), pointer :: ctx !< the context with which the handler should be called ! local integer(I4B) :: handler_idx class(EventHandlerDataType), pointer :: handler_data => null() @@ -49,7 +49,7 @@ subroutine mem_register_handler(var_name, mem_path, handler, ctx) logical(LGP) :: found ! first store the handler data - allocate(handler_data) + allocate (handler_data) handler_data%handler => handler handler_data%handlerContext => ctx @@ -74,9 +74,9 @@ subroutine mem_register_handler(var_name, mem_path, handler, ctx) !! because the data in memory is no longer consistent... !< subroutine on_memory_set(var_name, mem_path, status) - character(len=*), intent(in) :: var_name !< the variable name - character(len=*), intent(in) :: mem_path !< the memory path - integer(I4B), intent(out) :: status !< status: 0 for success, -1 when failed + character(len=*), intent(in) :: var_name !< the variable name + character(len=*), intent(in) :: mem_path !< the memory path + integer(I4B), intent(out) :: status !< status: 0 for success, -1 when failed ! local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -92,15 +92,15 @@ subroutine on_memory_set(var_name, mem_path, status) status = 0 return end if - + handler_data_genptr => handler_list%GetItem(mt%set_handler_idx) - select type(handler_data_genptr) + select type (handler_data_genptr) class is (EventHandlerDataType) evt_handler_data => handler_data_genptr end select - + ! call the function call evt_handler_data%handler(evt_handler_data%handlerContext, status) end subroutine -end module \ No newline at end of file +end module diff --git a/src/Utilities/Message.f90 b/src/Utilities/Message.f90 index 8298b3b6fdf..c4f40740dcb 100644 --- a/src/Utilities/Message.f90 +++ b/src/Utilities/Message.f90 @@ -1,36 +1,36 @@ !> @brief This module contains message methods !! -!! This module contains generic message methods that are used to +!! This module contains generic message methods that are used to !! create warning and error messages and notes. This module also has methods -!! for counting messages. The module does not have any dependencies on +!! for counting messages. The module does not have any dependencies on !! models, exchanges, or solutions in a simulation. !! !< module MessageModule - + use KindModule, only: LGP, I4B, DP - use ConstantsModule, only: LINELENGTH, MAXCHARLEN, DONE, & + use ConstantsModule, only: LINELENGTH, MAXCHARLEN, DONE, & VSUMMARY - use GenericUtilitiesModule, only: sim_message, write_message - use SimVariablesModule, only: istdout - use ArrayHandlersModule, only: ExpandArray - + use GenericUtilitiesModule, only: sim_message, write_message + use SimVariablesModule, only: istdout + use ArrayHandlersModule, only: ExpandArray + implicit none - + public :: MessageType - + type :: MessageType - character(len=LINELENGTH) :: title !< title of the message - character(len=LINELENGTH) :: name !< message name - integer(I4B) :: nmessage = 0 !< number of messages stored - integer(I4B) :: max_message = 1000 !< default maximum number of messages that can be stored - integer(I4B) :: max_exceeded = 0 !< flag indicating if the maximum number of messages has exceed the maximum number - integer(I4B) :: inc_message = 100 !< amount to increment message array by when calling ExpandArray - character(len=MAXCHARLEN), allocatable, dimension(:) :: message !< message array - - contains - + character(len=LINELENGTH) :: title !< title of the message + character(len=LINELENGTH) :: name !< message name + integer(I4B) :: nmessage = 0 !< number of messages stored + integer(I4B) :: max_message = 1000 !< default maximum number of messages that can be stored + integer(I4B) :: max_exceeded = 0 !< flag indicating if the maximum number of messages has exceed the maximum number + integer(I4B) :: inc_message = 100 !< amount to increment message array by when calling ExpandArray + character(len=MAXCHARLEN), allocatable, dimension(:) :: message !< message array + + contains + procedure :: init_message procedure :: count_message procedure :: set_max_message @@ -39,225 +39,224 @@ module MessageModule procedure :: deallocate_message end type MessageType - - contains - !> @brief Always initialize the message object +contains + + !> @brief Always initialize the message object !! - !! Subroutine that initializes the message object. Allocation of message + !! Subroutine that initializes the message object. Allocation of message !! array occurs on-the-fly. !! - !< - subroutine init_message(this) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - ! - ! -- initialize message variables - this%nmessage = 0 - this%max_message = 1000 - this%max_exceeded = 0 - this%inc_message = 100 - ! - ! -- return - return - end subroutine init_message - - !> @brief Return number of messages + !< + subroutine init_message(this) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + ! + ! -- initialize message variables + this%nmessage = 0 + this%max_message = 1000 + this%max_exceeded = 0 + this%inc_message = 100 + ! + ! -- return + return + end subroutine init_message + + !> @brief Return number of messages !! !! Function to return the number of messages that have been stored. !! !! @return ncount number of messages stored !! - !< - function count_message(this) result(nmessage) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - ! -- return variable - integer(I4B) :: nmessage - ! - ! -- set nmessage - if (allocated(this%message)) then - nmessage = this%nmessage - else - nmessage = 0 - end if - ! - ! -- return - return - end function count_message - - !> @brief Set the maximum number of messages stored + !< + function count_message(this) result(nmessage) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + ! -- return variable + integer(I4B) :: nmessage + ! + ! -- set nmessage + if (allocated(this%message)) then + nmessage = this%nmessage + else + nmessage = 0 + end if + ! + ! -- return + return + end function count_message + + !> @brief Set the maximum number of messages stored !! !! Subroutine to set the maximum number of messages that will be stored !! in a simulation. !! - !< - subroutine set_max_message(this, imax) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - integer(I4B), intent(in) :: imax !< maximum number of messages that will be stored - ! - ! -- set max_message - this%max_message = imax - ! - ! -- return - return - end subroutine set_max_message - - !> @brief Store message + !< + subroutine set_max_message(this, imax) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + integer(I4B), intent(in) :: imax !< maximum number of messages that will be stored + ! + ! -- set max_message + this%max_message = imax + ! + ! -- return + return + end subroutine set_max_message + + !> @brief Store message !! !! Subroutine to store a message for printing at the end of !! the simulation. !! - !< - subroutine store_message(this, msg, substring) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - character(len=*), intent(in) :: msg !< message - character(len=*), intent(in), optional :: substring !< optional string that can be used - !! to prevent storing duplicate messages - ! -- local variables - logical(LGP) :: inc_array - logical(LGP) :: increment_message - integer(I4B) :: i - integer(I4B) :: idx - ! - ! -- determine if messages should be expanded - inc_array = .TRUE. - if (allocated(this%message)) then - i = this%nmessage - if (i < size(this%message)) then - inc_array = .FALSE. - end if - end if - ! - ! -- resize message - if (inc_array) then - call ExpandArray(this%message, increment=this%inc_message) - this%inc_message = int(this%inc_message * 1.1) - end if - ! - ! -- Determine if the substring exists in the passed message. - ! If substring is in passed message, do not add the duplicate - ! passed message. - increment_message = .TRUE. - if (present(substring)) then - do i = 1, this%nmessage - idx = index(this%message(i), substring) - if (idx > 0) then - increment_message = .FALSE. - exit - end if - end do + !< + subroutine store_message(this, msg, substring) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + character(len=*), intent(in) :: msg !< message + character(len=*), intent(in), optional :: substring !< optional string that can be used + !! to prevent storing duplicate messages + ! -- local variables + logical(LGP) :: inc_array + logical(LGP) :: increment_message + integer(I4B) :: i + integer(I4B) :: idx + ! + ! -- determine if messages should be expanded + inc_array = .TRUE. + if (allocated(this%message)) then + i = this%nmessage + if (i < size(this%message)) then + inc_array = .FALSE. end if - ! - ! -- store this message and calculate nmessage - if (increment_message) then - i = this%nmessage + 1 - if (i <= this%max_message) then - this%nmessage = i - this%message(i) = msg - else - this%max_exceeded = this%max_exceeded + 1 + end if + ! + ! -- resize message + if (inc_array) then + call ExpandArray(this%message, increment=this%inc_message) + this%inc_message = int(this%inc_message * 1.1) + end if + ! + ! -- Determine if the substring exists in the passed message. + ! If substring is in passed message, do not add the duplicate + ! passed message. + increment_message = .TRUE. + if (present(substring)) then + do i = 1, this%nmessage + idx = index(this%message(i), substring) + if (idx > 0) then + increment_message = .FALSE. + exit end if + end do + end if + ! + ! -- store this message and calculate nmessage + if (increment_message) then + i = this%nmessage + 1 + if (i <= this%max_message) then + this%nmessage = i + this%message(i) = msg + else + this%max_exceeded = this%max_exceeded + 1 end if - ! - ! -- return - return - end subroutine store_message - - !> @brief Print messages + end if + ! + ! -- return + return + end subroutine store_message + + !> @brief Print messages !! !! Subroutine to print stored messages. !! - !< - subroutine print_message(this, title, name, iunit, level) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - character(len=*), intent(in) :: title !< message title - character(len=*), intent(in) :: name !< message name - integer(I4B), intent(in), optional :: iunit !< optional file unit to save messages to - integer(I4B), intent(in), optional :: level !< optional level of messages to print - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: cerr - integer(I4B) :: iu - integer(I4B) :: ilevel - integer(I4B) :: i - integer(I4B) :: isize - integer(I4B) :: iwidth - ! -- formats - character(len=*), parameter :: stdfmt = "(/,A,/)" - ! - ! -- process optional variables - if (present(iunit)) then - iu = iunit - else - iu = 0 - end if - if (present(level)) then - ilevel = level - else - ilevel = VSUMMARY - end if - ! - ! -- write the title and all message entries - if (allocated(this%message)) then - isize = this%nmessage - if (isize > 0) then - ! - ! -- calculate the maximum width of the prepended string - ! for the counter - write(cerr, '(i0)') isize - iwidth = len_trim(cerr) + 1 - ! - ! -- write title for message + !< + subroutine print_message(this, title, name, iunit, level) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + character(len=*), intent(in) :: title !< message title + character(len=*), intent(in) :: name !< message name + integer(I4B), intent(in), optional :: iunit !< optional file unit to save messages to + integer(I4B), intent(in), optional :: level !< optional level of messages to print + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: cerr + integer(I4B) :: iu + integer(I4B) :: ilevel + integer(I4B) :: i + integer(I4B) :: isize + integer(I4B) :: iwidth + ! -- formats + character(len=*), parameter :: stdfmt = "(/,A,/)" + ! + ! -- process optional variables + if (present(iunit)) then + iu = iunit + else + iu = 0 + end if + if (present(level)) then + ilevel = level + else + ilevel = VSUMMARY + end if + ! + ! -- write the title and all message entries + if (allocated(this%message)) then + isize = this%nmessage + if (isize > 0) then + ! + ! -- calculate the maximum width of the prepended string + ! for the counter + write (cerr, '(i0)') isize + iwidth = len_trim(cerr) + 1 + ! + ! -- write title for message + if (iu > 0) then + call sim_message(title, iunit=iu, fmt=stdfmt, level=ilevel) + end if + call sim_message(title, fmt=stdfmt, level=ilevel) + ! + ! -- write each message + do i = 1, isize + call write_message(this%message(i), icount=i, iwidth=iwidth, & + level=ilevel) if (iu > 0) then - call sim_message(title, iunit=iu, fmt=stdfmt, level=ilevel) - end if - call sim_message(title, fmt=stdfmt, level=ilevel) - ! - ! -- write each message - do i = 1, isize call write_message(this%message(i), icount=i, iwidth=iwidth, & - level=ilevel) - if (iu > 0) then - call write_message(this%message(i), icount=i, iwidth=iwidth, & - iunit=iu, level=ilevel) - end if - end do - ! - ! -- write the number of additional messages - if (this%max_exceeded > 0) then - write(errmsg, '(i0,3(1x,a))') & - this%max_exceeded, 'additional', trim(name), & - 'detected but not printed.' - call sim_message(trim(errmsg), fmt='(/,1x,a)', level=ilevel) - if (iu > 0) then - call sim_message(trim(errmsg), iunit=iu, fmt='(/,1x,a)', & - level=ilevel) - end if + iunit=iu, level=ilevel) + end if + end do + ! + ! -- write the number of additional messages + if (this%max_exceeded > 0) then + write (errmsg, '(i0,3(1x,a))') & + this%max_exceeded, 'additional', trim(name), & + 'detected but not printed.' + call sim_message(trim(errmsg), fmt='(/,1x,a)', level=ilevel) + if (iu > 0) then + call sim_message(trim(errmsg), iunit=iu, fmt='(/,1x,a)', & + level=ilevel) end if end if end if - ! - ! -- return - return - end subroutine print_message + end if + ! + ! -- return + return + end subroutine print_message - !> @ brief Deallocate message !! - !! Subroutine that deallocate the array of strings if it was allocated + !! Subroutine that deallocate the array of strings if it was allocated !! !< subroutine deallocate_message(this) ! -- dummy variables - class(MessageType) :: this !< MessageType object + class(MessageType) :: this !< MessageType object ! ! -- deallocate the message if (allocated(this%message)) then - deallocate(this%message) + deallocate (this%message) end if ! ! -- return diff --git a/src/Utilities/NameFile.f90 b/src/Utilities/NameFile.f90 index 6b6131b0401..115a8550c26 100644 --- a/src/Utilities/NameFile.f90 +++ b/src/Utilities/NameFile.f90 @@ -1,11 +1,11 @@ module NameFileModule use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, openfile, getunit - use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use InputOutputModule, only: ParseLine, openfile, getunit + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use ArrayHandlersModule, only: ExpandArray, remove_character - use IunitModule, only: IunitType - use BlockParserModule, only: BlockParserType + use IunitModule, only: IunitType + use BlockParserModule, only: BlockParserType implicit none private public :: NameFileType @@ -18,17 +18,17 @@ module NameFileModule type(IunitType) :: iunit_obj type(BlockParserType) :: parser contains - procedure :: init => namefile_init - procedure :: add_cunit => namefile_add_cunit - procedure :: openlistfile => namefile_openlistfile - procedure :: openfiles => namefile_openfiles - procedure :: get_unitnumber => namefile_get_unitnumber - procedure :: get_nval_for_row => namefile_get_nval_for_row + procedure :: init => namefile_init + procedure :: add_cunit => namefile_add_cunit + procedure :: openlistfile => namefile_openlistfile + procedure :: openfiles => namefile_openfiles + procedure :: get_unitnumber => namefile_get_unitnumber + procedure :: get_nval_for_row => namefile_get_nval_for_row procedure :: get_unitnumber_rowcol => namefile_get_unitnumber_rowcol - procedure :: get_pakname => namefile_get_pakname + procedure :: get_pakname => namefile_get_pakname end type NameFileType - contains +contains subroutine namefile_init(this, filename, iout) ! ****************************************************************************** @@ -49,9 +49,9 @@ subroutine namefile_init(this, filename, iout) integer(I4B) :: i, ierr, inunit, n logical :: isFound, endOfBlock ! -- formats - character(len=*), parameter :: fmtfname = & - "(1x, 'NON-COMMENTED ENTRIES FOUND IN ', /, & - &4X, 'BLOCK: ', a, /, & + character(len=*), parameter :: fmtfname = & + "(1x, 'NON-COMMENTED ENTRIES FOUND IN ', /, & + &4X, 'BLOCK: ', a, /, & &4X, 'FILE: ', a)" character(len=*), parameter :: fmtbeg = "(/, 1x, A)" character(len=*), parameter :: fmtline = "(2x, a)" @@ -60,8 +60,8 @@ subroutine namefile_init(this, filename, iout) ! ! -- Store filename and initialize variables this%filename = filename - allocate(this%opts(0)) - allocate(this%input_files(0)) + allocate (this%opts(0)) + allocate (this%input_files(0)) ! ! -- Open the name file and initialize the block parser inunit = getunit() @@ -70,8 +70,8 @@ subroutine namefile_init(this, filename, iout) ! ! -- Read and set the options call this%parser%GetBlock('OPTIONS', isFound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - if(isFound) then + supportOpenClose=.true., blockRequired=.false.) + if (isFound) then ! ! -- Populate this%opts n = 0 @@ -82,26 +82,26 @@ subroutine namefile_init(this, filename, iout) call ExpandArray(this%opts) n = n + 1 this%opts(n) = adjustl(line) - enddo getopts + end do getopts ! - if(iout > 0) then - write(iout, fmtfname) 'OPTIONS', trim(adjustl(filename)) - write(iout, fmtbeg) 'BEGIN OPTIONS' + if (iout > 0) then + write (iout, fmtfname) 'OPTIONS', trim(adjustl(filename)) + write (iout, fmtbeg) 'BEGIN OPTIONS' do i = 1, n - write(iout, fmtline) trim(adjustl(this%opts(i))) - enddo - write(iout, fmtend) 'END OPTIONS' - endif + write (iout, fmtline) trim(adjustl(this%opts(i))) + end do + write (iout, fmtend) 'END OPTIONS' + end if else - if(iout > 0) then - write(iout, '(/, A, /)') 'NO VALID OPTIONS BLOCK DETECTED' - endif - endif + if (iout > 0) then + write (iout, '(/, A, /)') 'NO VALID OPTIONS BLOCK DETECTED' + end if + end if ! ! -- Read and set the input_files call this%parser%GetBlock('PACKAGES', isFound, ierr, & - supportOpenClose=.true.) - if(isFound) then + supportOpenClose=.true.) + if (isFound) then ! ! -- Populate this%input_files n = 0 @@ -112,24 +112,24 @@ subroutine namefile_init(this, filename, iout) call ExpandArray(this%input_files) n = n + 1 this%input_files(n) = adjustl(line) - enddo getpaks + end do getpaks ! ! -- Write to list file - if(iout > 0) then - write(iout, fmtfname) 'PACKAGES', trim(adjustl(filename)) - write(iout, fmtbeg) 'BEGIN PACKAGES' + if (iout > 0) then + write (iout, fmtfname) 'PACKAGES', trim(adjustl(filename)) + write (iout, fmtbeg) 'BEGIN PACKAGES' do i = 1, n - write(iout, fmtline) trim(adjustl(this%input_files(i))) - enddo - write(iout, fmtend) 'END PACKAGES' - endif + write (iout, fmtline) trim(adjustl(this%input_files(i))) + end do + write (iout, fmtend) 'END PACKAGES' + end if else ! ! -- Package block not found. Terminate with error. - write(errmsg, '(a, a)') 'Error reading PACKAGES from file: ', & - trim(adjustl(filename)) + write (errmsg, '(a, a)') 'Error reading PACKAGES from file: ', & + trim(adjustl(filename)) call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- return return @@ -182,13 +182,13 @@ subroutine namefile_openlistfile(this, iout) findloop: do i = 1, size(this%opts) call ParseLine(this%opts(i), nwords, words) call upcase(words(1)) - if(words(1) == 'LIST') then + if (words(1) == 'LIST') then fname = words(2) ipos = i found = .true. exit findloop - endif - enddo findloop + end if + end do findloop ! ! -- remove list file from options list if (ipos > 0) then @@ -206,13 +206,13 @@ subroutine namefile_openlistfile(this, iout) if (this%filename(i:i) == '.') then istart = i exit - endif - enddo + end if + end do if (istart == 0) istart = istop + 1 fname = this%filename(1:istart) istop = istart + 3 fname(istart:istop) = '.lst' - endif + end if ! ! -- Open the list file iout = getunit() @@ -248,7 +248,7 @@ subroutine namefile_openfiles(this, iout) ! -- Parse the line and set defaults call ParseLine(this%input_files(i), nwords, words) call upcase(words(1)) - ftype = words(1)(1:20) + ftype = words(1) (1:20) accarg = 'SEQUENTIAL' fmtarg = 'FORMATTED' filstat = 'OLD' @@ -258,9 +258,9 @@ subroutine namefile_openfiles(this, iout) call this%iunit_obj%addfile(ftype, inunit, i, this%filename) ! ! -- Open the file - call openfile(inunit, iout, trim(adjustl(words(2))), & + call openfile(inunit, iout, trim(adjustl(words(2))), & ftype, fmtarg, accarg, filstat) - enddo + end do ! ! -- return return @@ -307,8 +307,8 @@ function namefile_get_nval_for_row(this, irow) result(nval) return end function namefile_get_nval_for_row - function namefile_get_unitnumber_rowcol(this, irow, jcol) & - result(iu) + function namefile_get_unitnumber_rowcol(this, irow, jcol) & + result(iu) ! ****************************************************************************** ! namefile_get_unitnumber_rowcol -- Get the unit number for entries in ! cunit(irow) and columns (icol). For example, return the unit number for @@ -358,23 +358,22 @@ subroutine namefile_get_pakname(this, irow, jcol, pakname) pakname = '' if (nwords > 2) then ilen = len(trim(adjustl(words(3)))) - if(ilen > LENPACKAGENAME) then - write(errmsg, "(a, i0, a)") & - 'ERROR. PACKAGENAME MUST NOT BE GREATER THAN ', & - LENPACKAGENAME, ' CHARACTERS.' + if (ilen > LENPACKAGENAME) then + write (errmsg, "(a, i0, a)") & + 'ERROR. PACKAGENAME MUST NOT BE GREATER THAN ', & + LENPACKAGENAME, ' CHARACTERS.' call store_error(errmsg) call store_error(trim(this%input_files(ipos))) - write(errmsg, '(a, a)') 'Error in PACKAGES block in file: ', & - trim(adjustl(this%filename)) + write (errmsg, '(a, a)') 'Error in PACKAGES block in file: ', & + trim(adjustl(this%filename)) call store_error(errmsg, terminate=.TRUE.) - endif + end if pakname = trim(adjustl(words(3))) call upcase(pakname) - endif + end if ! ! -- return return end subroutine namefile_get_pakname - end module NameFileModule diff --git a/src/Utilities/Observation/Obs3.f90 b/src/Utilities/Observation/Obs3.f90 index e0e883801c2..54c4cc8e4a2 100644 --- a/src/Utilities/Observation/Obs3.f90 +++ b/src/Utilities/Observation/Obs3.f90 @@ -126,34 +126,34 @@ !------------------------------------------------------------------------------- module ObsModule - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B use ArrayHandlersModule, only: ExpandArray - use BaseDisModule, only: DisBaseType - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LENBIGLINE, LENFTYPE, LENOBSNAME, & - LENOBSTYPE, LENPACKAGENAME, LENBOUNDNAME, & - LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & - MAXOBSTYPES, LENHUGELINE, DNODATA, & - TABLEFT - use TableModule, only: TableType, table_cr - use InputOutputModule, only: UPCASE, openfile, GetUnit, GetFileFromPath - use ListModule, only: ListType - use ObsContainerModule, only: ObsContainerType - use ObserveModule, only: ConstructObservation, ObsDataType, & - ObserveType, GetObsFromList, & - AddObsToList + use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LENBIGLINE, LENFTYPE, LENOBSNAME, & + LENOBSTYPE, LENPACKAGENAME, LENBOUNDNAME, & + LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & + MAXOBSTYPES, LENHUGELINE, DNODATA, & + TABLEFT + use TableModule, only: TableType, table_cr + use InputOutputModule, only: UPCASE, openfile, GetUnit, GetFileFromPath + use ListModule, only: ListType + use ObsContainerModule, only: ObsContainerType + use ObserveModule, only: ConstructObservation, ObsDataType, & + ObserveType, GetObsFromList, & + AddObsToList use ObsOutputListModule, only: ObsOutputListType - use ObsOutputModule, only: ObsOutputType - use ObsUtilityModule, only: write_fmtd_cont, write_unfmtd_cont - use OpenSpecModule, only: ACCESS, FORM - use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, store_error_unit - use TdisModule, only: totim + use ObsOutputModule, only: ObsOutputType + use ObsUtilityModule, only: write_fmtd_cont, write_unfmtd_cont + use OpenSpecModule, only: ACCESS, FORM + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error, store_error_unit + use TdisModule, only: totim implicit none private - public :: ObsType, DefaultObsIdProcessor, obs_cr + public :: ObsType, DefaultObsIdProcessor, obs_cr type :: ObsType ! -- Public members @@ -161,17 +161,17 @@ module ObsModule integer(I4B), public :: npakobs = 0 integer(I4B), pointer, public :: inUnitObs => null() character(len=LINELENGTH), pointer, public :: inputFilename => null() - character(len=2*LENPACKAGENAME+4), public :: pkgName = '' + character(len=2*LENPACKAGENAME + 4), public :: pkgName = '' character(len=LENFTYPE), public :: filtyp = '' logical, pointer, public :: active => null() type(ObsContainerType), dimension(:), pointer, public :: pakobs => null() type(ObsDataType), dimension(:), pointer, public :: obsData => null() ! -- Private members - integer(I4B), private :: iprecision = 2 ! 2=double; 1=single + integer(I4B), private :: iprecision = 2 ! 2=double; 1=single integer(I4B), private :: idigits = 0 character(len=LINELENGTH), private :: outputFilename = '' character(len=LINELENGTH), private :: blockTypeFound = '' - character(len=20), private:: obsfmtcont = '' + character(len=20), private :: obsfmtcont = '' logical, private :: echo = .false. logical, private :: more type(ListType), private :: obsList @@ -183,15 +183,15 @@ module ObsModule type(TableType), pointer :: obstab => null() contains ! -- Public procedures - procedure, public :: obs_df - procedure, public :: obs_ar - procedure, public :: obs_ad - procedure, public :: obs_bd_clear - procedure, public :: obs_ot - procedure, public :: obs_da - procedure, public :: SaveOneSimval - procedure, public :: StoreObsType - procedure, public :: allocate_scalars + procedure, public :: obs_df + procedure, public :: obs_ar + procedure, public :: obs_ad + procedure, public :: obs_bd_clear + procedure, public :: obs_ot + procedure, public :: obs_da + procedure, public :: SaveOneSimval + procedure, public :: StoreObsType + procedure, public :: allocate_scalars ! -- Private procedures procedure, private :: build_headers procedure, private :: define_fmts @@ -223,11 +223,11 @@ subroutine obs_cr(obs, inobs) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ObsType), pointer, intent(out) :: obs + type(ObsType), pointer, intent(out) :: obs integer(I4B), pointer, intent(in) :: inobs ! ------------------------------------------------------------------------------ ! - allocate(obs) + allocate (obs) call obs%allocate_scalars() obs%inUnitObs => inobs ! @@ -261,7 +261,7 @@ subroutine DefaultObsIdProcessor(obsrv, dis, inunitobs, iout) ! -- Initialize variables strng = obsrv%IDstring icol = 1 - flag_string = .true. ! Allow strng to contain a boundary name + flag_string = .true. ! Allow strng to contain a boundary name ! n = dis%noder_from_string(icol, istart, istop, inunitobs, & iout, strng, flag_string) @@ -280,7 +280,7 @@ subroutine DefaultObsIdProcessor(obsrv, dis, inunitobs, iout) errmsg = 'Error reading data from ID string' call store_error(errmsg) call store_error_unit(inunitobs) - endif + end if ! return end subroutine DefaultObsIdProcessor @@ -299,7 +299,7 @@ subroutine obs_df(this, iout, pkgname, filtyp, dis) integer(I4B), intent(in) :: iout character(len=*), intent(in) :: pkgname character(len=*), intent(in) :: filtyp - class(DisBaseType), pointer :: dis + class(DisBaseType), pointer :: dis ! ------------------------------------------------------------------------------ ! this%iout = iout @@ -329,7 +329,7 @@ subroutine obs_ar(this) call this%obs_ar1(this%pkgName) if (this%active) then call this%obs_ar2(this%dis) - endif + end if ! return end subroutine obs_ar @@ -350,10 +350,10 @@ subroutine obs_ad(this) ! ------------------------------------------------------------------------------ ! n = this%get_num() - do i=1,n + do i = 1, n obsrv => this%get_obs(i) call obsrv%ResetCurrent() - enddo + end do ! return end subroutine obs_ad @@ -396,7 +396,7 @@ subroutine obs_ot(this) if (this%npakobs > 0) then call this%write_continuous_simvals() call this%obsOutputList%WriteOutputLines() - endif + end if ! return end subroutine obs_ot @@ -415,15 +415,15 @@ subroutine obs_da(this) class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! - deallocate(this%active) - deallocate(this%inputFilename) - deallocate(this%obsData) + deallocate (this%active) + deallocate (this%inputFilename) + deallocate (this%obsData) ! ! -- obs table object if (associated(this%obstab)) then call this%obstab%table_da() - deallocate(this%obstab) - nullify(this%obstab) + deallocate (this%obstab) + nullify (this%obstab) end if ! ! -- deallocate pakobs components and pakobs @@ -431,21 +431,21 @@ subroutine obs_da(this) do i = 1, this%npakobs obsrv => this%pakobs(i)%obsrv call obsrv%da() - deallocate(obsrv) - nullify(this%pakobs(i)%obsrv) + deallocate (obsrv) + nullify (this%pakobs(i)%obsrv) end do - deallocate(this%pakobs) + deallocate (this%pakobs) end if ! ! -- deallocate obsOutputList call this%obsOutputList%DeallocObsOutputList() - deallocate(this%obsOutputList) + deallocate (this%obsOutputList) ! ! -- deallocate obslist call this%obslist%Clear() ! ! -- nullify - nullify(this%inUnitObs) + nullify (this%inUnitObs) ! return end subroutine obs_da @@ -460,9 +460,9 @@ subroutine SaveOneSimval(this, obsrv, simval) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(ObsType) :: this + class(ObsType) :: this class(ObserveType), intent(inout) :: obsrv - real(DP), intent(in) :: simval + real(DP), intent(in) :: simval ! -- local character(len=LENOBSTYPE) :: obsTypeID type(ObsDataType), pointer :: obsDatum => null() @@ -480,7 +480,7 @@ subroutine SaveOneSimval(this, obsrv, simval) obsrv%CurrentTimeStepEndValue = obsrv%CurrentTimeStepEndValue + simval else obsrv%CurrentTimeStepEndValue = simval - endif + end if ! return end subroutine SaveOneSimval @@ -497,37 +497,37 @@ subroutine StoreObsType(this, obsrvType, cumulative, indx) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - character(len=*), intent(in) :: obsrvType + character(len=*), intent(in) :: obsrvType ! cumulative: Accumulate simulated values for multiple boundaries - logical, intent(in) :: cumulative - integer(I4B), intent(out) :: indx + logical, intent(in) :: cumulative + integer(I4B), intent(out) :: indx ! -- local integer(I4B) :: i - character(len=LENOBSTYPE) :: obsTypeUpper + character(len=LENOBSTYPE) :: obsTypeUpper character(len=100) :: msg ! ------------------------------------------------------------------------------ ! ! -- Ensure that obsrvType is not blank - if (obsrvType=='') then + if (obsrvType == '') then msg = 'Programmer error: Invalid argument in store_obs_type.' call store_error(msg, terminate=.TRUE.) - endif + end if ! ! -- Find first unused element indx = -1 - do i=1,MAXOBSTYPES + do i = 1, MAXOBSTYPES if (this%obsData(i)%ObsTypeID /= '') cycle indx = i exit - enddo + end do ! ! -- Ensure that array size is not exceeded if (indx == -1) then msg = 'Size of obsData array is insufficient; ' & - // 'need to increase MAXOBSTYPES.' + //'need to increase MAXOBSTYPES.' call store_error(msg) call store_error_unit(this%inUnitObs) - endif + end if ! ! -- Convert character argument to upper case obsTypeUpper = obsrvType @@ -553,10 +553,10 @@ subroutine allocate_scalars(this) class(ObsType) :: this ! ------------------------------------------------------------------------------ ! - allocate(this%active) - allocate(this%inputFilename) - allocate(this%obsOutputList) - allocate(this%obsData(MAXOBSTYPES)) + allocate (this%active) + allocate (this%inputFilename) + allocate (this%obsOutputList) + allocate (this%obsData(MAXOBSTYPES)) ! ! -- Initialize this%active = .false. @@ -578,21 +578,21 @@ subroutine obs_ar1(this, pkgname) class(ObsType), intent(inout) :: this character(len=*), intent(in) :: pkgname ! -- formats - 10 format(/,'The observation utility is active for "',a,'"') +10 format(/, 'The observation utility is active for "', a, '"') ! ------------------------------------------------------------------------------ ! if (this%inUnitObs > 0) then this%active = .true. ! ! -- Indicate that OBS is active - write(this%iout,10)trim(pkgname) + write (this%iout, 10) trim(pkgname) ! ! -- Read Options block call this%read_obs_options() ! ! -- define output formats call this%define_fmts() - endif + end if ! return end subroutine obs_ar1 @@ -608,11 +608,11 @@ subroutine obs_ar2(this, dis) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - class(DisBaseType) :: dis + class(DisBaseType) :: dis ! -- local integer(I4B) :: i - type(ObsDataType), pointer :: obsDat => null() - character(len=LENOBSTYPE) :: obsTypeID + type(ObsDataType), pointer :: obsDat => null() + character(len=LENOBSTYPE) :: obsTypeID class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! @@ -620,19 +620,19 @@ subroutine obs_ar2(this, dis) ! -- allocate and populate observations array call this%get_obs_array(this%npakobs, this%pakobs) ! - do i=1,this%npakobs + do i = 1, this%npakobs obsrv => this%pakobs(i)%obsrv ! -- Call IDstring processor procedure provided by package obsTypeID = obsrv%ObsTypeId obsDat => this%get_obs_datum(obsTypeID) if (associated(obsDat%ProcessIdPtr)) then call obsDat%ProcessIdPtr(obsrv, dis, & - this%inUnitObs, this%iout) + this%inUnitObs, this%iout) else call DefaultObsIdProcessor(obsrv, dis, & - this%inUnitObs, this%iout) - endif - enddo + this%inUnitObs, this%iout) + end if + end do ! if (count_errors() > 0) then call store_error_unit(this%inunitobs) @@ -662,9 +662,9 @@ subroutine read_obs_options(this) logical :: continueread, found, endOfBlock ! -- formats 10 format('No options block found in OBS input. Defaults will be used.') -40 format('Text output number of digits of precision set to: ',i2) +40 format('Text output number of digits of precision set to: ', i2) 50 format('Text output number of digits set to internal representation (G0).') -60 format(/,'Processing observation options:',/) +60 format(/, 'Processing observation options:',/) ! ------------------------------------------------------------------------------ ! localprecision = 0 @@ -673,7 +673,7 @@ subroutine read_obs_options(this) ! ! -- Find and store file name iin = this%inUnitObs - inquire(unit=iin, name=fname) + inquire (unit=iin, name=fname) this%inputFilename = fname ! ! -- Read Options block @@ -682,22 +682,22 @@ subroutine read_obs_options(this) ! ! -- get BEGIN line of OPTIONS block call this%parser%GetBlock('OPTIONS', found, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) if (ierr /= 0) then ! end of file - errmsg = 'End-of-file encountered while searching for' // & - ' OPTIONS in OBS ' // & - 'input file "' // trim(this%inputFilename) // '"' + errmsg = 'End-of-file encountered while searching for'// & + ' OPTIONS in OBS '// & + 'input file "'//trim(this%inputFilename)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() elseif (.not. found) then this%blockTypeFound = '' - if (this%iout>0) write(this%iout,10) - endif + if (this%iout > 0) write (this%iout, 10) + end if ! ! -- parse OPTIONS entries if (found) then - write(this%iout,60) + write (this%iout, 60) readblockoptions: do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -720,33 +720,33 @@ subroutine read_obs_options(this) ! ! -- Set localdigits to valid value: 0, or 2 to 16 if (localdigits == 0) then - write(this%iout, 50) + write (this%iout, 50) else if (localdigits < 1) then - errmsg = 'Error in OBS input: Invalid value for DIGITS option' - call store_error(errmsg) - exit readblockoptions + errmsg = 'Error in OBS input: Invalid value for DIGITS option' + call store_error(errmsg) + exit readblockoptions else if (localdigits < 2) localdigits = 2 if (localdigits > 16) localdigits = 16 - write(this%iout, 40) localdigits + write (this%iout, 40) localdigits end if case ('PRINT_INPUT') this%echo = .true. - write(this%iout,'(a)')'The PRINT_INPUT option has been specified.' + write (this%iout, '(a)') 'The PRINT_INPUT option has been specified.' case default - errmsg = 'Error in OBS input: Unrecognized option: ' // & - trim(keyword) + errmsg = 'Error in OBS input: Unrecognized option: '// & + trim(keyword) call store_error(errmsg) exit readblockoptions end select - enddo readblockoptions - endif + end do readblockoptions + end if ! - if (count_errors()>0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! - write(this%iout,'(1x)') + write (this%iout, '(1x)') ! ! -- Assign type variables if (localprecision > 0) this%iprecision = localprecision @@ -766,13 +766,13 @@ subroutine define_fmts(this) ! -- dummy class(ObsType) :: this ! formats -50 format('(g',i2.2,'.',i2.2,')') +50 format('(g', i2.2, '.', i2.2, ')') ! ------------------------------------------------------------------------------ ! if (this%idigits == 0) then this%obsfmtcont = '(G0)' else - write(this%obsfmtcont,50) this%idigits+7, this%idigits + write (this%obsfmtcont, 50) this%idigits + 7, this%idigits end if return end subroutine define_fmts @@ -838,9 +838,9 @@ subroutine build_headers(this) integer(I4B) :: iu integer(I4B) :: num integer(int32) :: nobs - character(len=4) :: clenobsname - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() + character(len=4) :: clenobsname + type(ObserveType), pointer :: obsrv => null() + type(ObsOutputType), pointer :: obsOutput => null() ! ------------------------------------------------------------------------------ ! ! -- Cycle through ObsOutputList to write headers @@ -854,40 +854,40 @@ subroutine build_headers(this) ! ! -- write header information to the formatted file if (obsOutput%FormattedOutput) then - write(iu, '(a)', advance='NO') 'time' + write (iu, '(a)', advance='NO') 'time' else ! -- write header to unformatted file ! First 11 bytes are obs type and precision - if (this%iprecision==1) then + if (this%iprecision == 1) then ! -- single precision output - write(iu) 'cont single' - else if (this%iprecision==2) then + write (iu) 'cont single' + else if (this%iprecision == 2) then ! -- double precision output - write(iu) 'cont double' + write (iu) 'cont double' end if ! -- write LENOBSNAME to bytes 12-15 - write(clenobsname,'(i4)') LENOBSNAME - write(iu) clenobsname + write (clenobsname, '(i4)') LENOBSNAME + write (iu) clenobsname ! -- write blanks to complete 100-byte header do ii = 16, 100 - write(iu) ' ' + write (iu) ' ' end do ! -- write NOBS - write(iu) nobs + write (iu) nobs end if ! ! -- write observation name obsfile: do ii = 1, nobs obsrv => this%get_obs(idx) if (obsOutput%FormattedOutput) then - write(iu, '(a,a)', advance='NO') ',', trim(obsrv%Name) + write (iu, '(a,a)', advance='NO') ',', trim(obsrv%Name) ! ! -- terminate the line on the last observation in file if (ii == nobs) then - write(iu, '(a)', advance='YES') '' + write (iu, '(a)', advance='YES') '' end if else - write(iu) obsrv%Name + write (iu) obsrv%Name end if idx = idx + 1 end do obsfile @@ -907,19 +907,19 @@ subroutine get_obs_array(this, nObs, obsArray) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - integer(I4B), intent(out) :: nObs + integer(I4B), intent(out) :: nObs type(ObsContainerType), dimension(:), pointer, intent(inout) :: obsArray ! -- local ! ------------------------------------------------------------------------------ ! nObs = this%get_num() - if (associated(obsArray)) deallocate(obsArray) - allocate(obsArray(nObs)) + if (associated(obsArray)) deallocate (obsArray) + allocate (obsArray(nObs)) ! ! Get observations if (nObs > 0) then call this%populate_obs_array(nObs, obsArray) - endif + end if ! return end subroutine get_obs_array @@ -941,18 +941,18 @@ function get_obs_datum(this, obsTypeID) result(obsDatum) ! ------------------------------------------------------------------------------ ! obsDatum => null() - do i=1,MAXOBSTYPES + do i = 1, MAXOBSTYPES if (this%obsData(i)%ObsTypeID == obsTypeID) then obsDatum => this%obsData(I) exit - endif - enddo + end if + end do ! if (.not. associated(obsDatum)) then - errmsg = 'Observation type not found: ' // trim(obsTypeID) + errmsg = 'Observation type not found: '//trim(obsTypeID) call store_error(errmsg) call store_error_unit(this%inUnitObs) - endif + end if ! return end function get_obs_datum @@ -967,7 +967,7 @@ subroutine populate_obs_array(this, nObs, obsArray) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - integer(I4B), intent(in) :: nObs + integer(I4B), intent(in) :: nObs type(ObsContainerType), dimension(nObs), intent(inout) :: obsArray ! ------------------------------------------------------------------------------ ! @@ -976,10 +976,10 @@ subroutine populate_obs_array(this, nObs, obsArray) type(ObserveType), pointer :: obsrv => null() ! n = this%get_num() - do i=1,n + do i = 1, n obsrv => this%get_obs(i) obsArray(i)%obsrv => obsrv - enddo + end do ! return end subroutine populate_obs_array @@ -994,7 +994,7 @@ function get_obs(this, indx) result(obsrv) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType) :: this - integer(I4B), intent(in) :: indx + integer(I4B), intent(in) :: indx class(ObserveType), pointer :: obsrv ! -- local ! ------------------------------------------------------------------------------ @@ -1024,8 +1024,8 @@ subroutine read_obs_blocks(this, fname) character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag character(len=20) :: accarg, bin, fmtarg - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() + type(ObserveType), pointer :: obsrv => null() + type(ObsOutputType), pointer :: obsOutput => null() integer(I4B) :: ntabrows integer(I4B) :: ntabcols ! -- formats @@ -1035,7 +1035,7 @@ subroutine read_obs_blocks(this, fname) numspec = -1 errmsg = '' ! - inquire(unit=this%parser%iuactive, name=pnamein) + inquire (unit=this%parser%iuactive, name=pnamein) call GetFileFromPath(pnamein, fnamein) ! if (this%echo) then @@ -1046,18 +1046,18 @@ subroutine read_obs_blocks(this, fname) ntabcols = 5 ! ! -- initialize table and define columns - title = 'OBSERVATIONS READ FROM FILE "' // trim(fnamein) // '"' + title = 'OBSERVATIONS READ FROM FILE "'//trim(fnamein)//'"' call table_cr(this%obstab, fnamein, title) - call this%obstab%table_df(ntabrows, ntabcols, this%iout, & + call this%obstab%table_df(ntabrows, ntabcols, this%iout, & finalize=.FALSE.) tag = 'NAME' call this%obstab%initialize_column(tag, LENOBSNAME, alignment=TABLEFT) tag = 'TYPE' - call this%obstab%initialize_column(tag, LENOBSTYPE+12, alignment=TABLEFT) + call this%obstab%initialize_column(tag, LENOBSTYPE + 12, alignment=TABLEFT) tag = 'TIME' call this%obstab%initialize_column(tag, 12, alignment=TABLEFT) tag = 'LOCATION DATA' - call this%obstab%initialize_column(tag, LENBOUNDNAME+2, alignment=TABLEFT) + call this%obstab%initialize_column(tag, LENBOUNDNAME + 2, alignment=TABLEFT) tag = 'OUTPUT FILENAME' call this%obstab%initialize_column(tag, 80, alignment=TABLEFT) end if @@ -1075,8 +1075,8 @@ subroutine read_obs_blocks(this, fname) ! Get keyword, which should be FILEOUT call this%parser%GetStringCaps(word) if (word /= 'FILEOUT') then - call store_error('CONTINUOUS keyword must be followed by ' // & - '"FILEOUT" then by filename.') + call store_error('CONTINUOUS keyword must be followed by '// & + '"FILEOUT" then by filename.') cycle end if ! @@ -1084,13 +1084,13 @@ subroutine read_obs_blocks(this, fname) call this%parser%GetString(fname) ! Fname is the output file name defined in the BEGIN line of the block. if (fname == '') then - message = 'Error reading OBS input file, likely due to bad' // & + message = 'Error reading OBS input file, likely due to bad'// & ' block or missing file name.' call store_error(message) cycle else if (this%obsOutputList%ContainsFile(fname)) then - errmsg = 'OBS outfile "' // trim(fname) // & - '" is provided more than once.' + errmsg = 'OBS outfile "'//trim(fname)// & + '" is provided more than once.' call store_error(errmsg) cycle end if @@ -1105,16 +1105,16 @@ subroutine read_obs_blocks(this, fname) fmtarg = 'FORMATTED' accarg = 'SEQUENTIAL' fmtd = .true. - endif + end if ! ! -- open the output file numspec = 0 - call openfile(numspec, 0, fname, 'OBS OUTPUT', fmtarg, & + call openfile(numspec, 0, fname, 'OBS OUTPUT', fmtarg, & accarg, 'REPLACE') ! ! -- add output file to list of output files and assign its ! FormattedOutput member appropriately - call this%obsOutputList%Add(fname,numspec) + call this%obsOutputList%Add(fname, numspec) indexobsout = this%obsOutputList%Count() obsOutput => this%obsOutputList%Get(indexobsout) obsOutput%FormattedOutput = fmtd @@ -1144,8 +1144,8 @@ subroutine read_obs_blocks(this, fname) end if end do readblockcontinuous case default - errmsg = 'Error: Observation block type not recognized: ' // & - trim(btagfound) + errmsg = 'Error: Observation block type not recognized: '// & + trim(btagfound) call store_error(errmsg) end select end do readblocks @@ -1175,9 +1175,9 @@ subroutine write_continuous_simvals(this) ! -- dummy class(ObsType), intent(inout) :: this ! -- local - integer(I4B) :: i, iprec, numobs - character(len=20) :: fmtc - real(DP) :: simval + integer(I4B) :: i, iprec, numobs + character(len=20) :: fmtc + real(DP) :: simval class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! @@ -1186,7 +1186,7 @@ subroutine write_continuous_simvals(this) fmtc = this%obsfmtcont ! -- iterate through all observations numobs = this%obsList%Count() - do i=1,numobs + do i = 1, numobs obsrv => this%get_obs(i) ! -- continuous observation simval = obsrv%CurrentTimeStepEndValue @@ -1194,11 +1194,11 @@ subroutine write_continuous_simvals(this) call write_fmtd_cont(fmtc, obsrv, this%obsOutputList, simval) else call write_unfmtd_cont(obsrv, iprec, this%obsOutputList, simval) - endif + end if end do ! ! -- flush file - flush(obsrv%UnitNumber) + flush (obsrv%UnitNumber) ! ! --return return diff --git a/src/Utilities/Observation/ObsContainer.f90 b/src/Utilities/Observation/ObsContainer.f90 index ee36ab30d66..b59dac00617 100644 --- a/src/Utilities/Observation/ObsContainer.f90 +++ b/src/Utilities/Observation/ObsContainer.f90 @@ -16,7 +16,7 @@ module ObsContainerModule type :: ObsContainerType ! -- Public members - class(ObserveType), pointer, public :: obsrv => null() + class(ObserveType), pointer, public :: obsrv => null() end type ObsContainerType end module ObsContainerModule diff --git a/src/Utilities/Observation/ObsOutput.f90 b/src/Utilities/Observation/ObsOutput.f90 index 2109e61c449..a467031acbe 100644 --- a/src/Utilities/Observation/ObsOutput.f90 +++ b/src/Utilities/Observation/ObsOutput.f90 @@ -64,9 +64,9 @@ subroutine WriteLineout(this) implicit none ! -- dummy class(ObsOutputType), intent(inout) :: this - ! -- write a line return to end of observation output line + ! -- write a line return to end of observation output line ! for this totim - write(this%nunit,'(a)', advance='YES') '' + write (this%nunit, '(a)', advance='YES') '' ! return end subroutine WriteLineout @@ -115,7 +115,7 @@ subroutine ConstructObsOutput(newObsOutput, fname, nunit) character(len=*), intent(in) :: fname integer(I4B), intent(in) :: nunit ! - allocate(newObsOutput) + allocate (newObsOutput) newObsOutput%filename = fname newObsOutput%nunit = nunit return @@ -124,7 +124,7 @@ end subroutine ConstructObsOutput subroutine AddObsOutputToList(list, obsOutput) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(ObsOutputType), pointer, intent(inout) :: obsOutput ! -- local class(*), pointer :: obj @@ -135,12 +135,12 @@ subroutine AddObsOutputToList(list, obsOutput) return end subroutine AddObsOutputToList - function GetObsOutputFromList(list, idx) result (res) + function GetObsOutputFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(ObsOutputType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + type(ObsOutputType), pointer :: res ! -- local class(*), pointer :: obj ! diff --git a/src/Utilities/Observation/ObsOutputList.f90 b/src/Utilities/Observation/ObsOutputList.f90 index 6a9f01b0598..55de0b7665f 100644 --- a/src/Utilities/Observation/ObsOutputList.f90 +++ b/src/Utilities/Observation/ObsOutputList.f90 @@ -10,7 +10,7 @@ module ObsOutputListModule use KindModule, only: DP, I4B use InputOutputModule, only: same_word use ListModule, only: ListType - use ObsOutputModule, only: ObsOutputType, ConstructObsOutput, & + use ObsOutputModule, only: ObsOutputType, ConstructObsOutput, & AddObsOutputToList, GetObsOutputFromList implicit none @@ -51,10 +51,10 @@ subroutine ClearOutputLines(this) type(ObsOutputType), pointer :: obsOutput => null() ! num = this%Count() - do i=1,num + do i = 1, num obsOutput => this%Get(i) call obsOutput%ClearLineout() - enddo + end do ! return end subroutine ClearOutputLines @@ -76,7 +76,7 @@ function Count(this) return end function Count - logical function ContainsFile(this,fname) + logical function ContainsFile(this, fname) ! ************************************************************************** ! ContainsFile -- return true if filename fname is included in list of ! ObsOutputType objects @@ -87,24 +87,24 @@ logical function ContainsFile(this,fname) implicit none ! -- dummy class(ObsOutputListType), intent(inout) :: this - character(len=*), intent(in) :: fname + character(len=*), intent(in) :: fname ! -- local type(ObsOutputType), pointer :: obsOutput => null() integer(I4B) :: i, n ! ContainsFile = .false. n = this%Count() - loop1: do i=1,n + loop1: do i = 1, n obsOutput => this%Get(i) - if (same_word(obsOutput%filename,fname)) then + if (same_word(obsOutput%filename, fname)) then ContainsFile = .true. exit loop1 - endif - enddo loop1 + end if + end do loop1 return end function ContainsFile - subroutine Add(this,fname,nunit) + subroutine Add(this, fname, nunit) ! ************************************************************************** ! Add -- construct a new ObsOutputType object with arguments assigned to ! its members, and add the new object to the list @@ -115,8 +115,8 @@ subroutine Add(this,fname,nunit) implicit none ! -- dummy class(ObsOutputListType), intent(inout) :: this - character(len=*), intent(in) :: fname - integer(I4B), intent(in) :: nunit + character(len=*), intent(in) :: fname + integer(I4B), intent(in) :: nunit ! -- local type(ObsOutputType), pointer :: obsOutput => null() ! @@ -143,12 +143,12 @@ subroutine WriteOutputLines(this) integer(I4B) :: i, num ! num = this%Count() - do i=1,num + do i = 1, num obsOutput => this%Get(i) if (obsOutput%FormattedOutput) then call obsOutput%WriteLineout() - endif - enddo + end if + end do ! return end subroutine WriteOutputLines @@ -196,10 +196,10 @@ subroutine DeallocObsOutputList(this) type(ObsOutputType), pointer :: obsoutput => null() ! n = this%Count() - do i=1,n + do i = 1, n obsoutput => GetObsOutputFromList(this%ObsOutputs, i) !call obsoutput%DeallocObsOutput() - enddo + end do ! call this%ObsOutputs%Clear(.true.) ! diff --git a/src/Utilities/Observation/ObsUtility.f90 b/src/Utilities/Observation/ObsUtility.f90 index b8e90576b6b..1b04c70a9c4 100644 --- a/src/Utilities/Observation/ObsUtility.f90 +++ b/src/Utilities/Observation/ObsUtility.f90 @@ -6,11 +6,11 @@ module ObsUtilityModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENOBSNAME, LENBIGLINE - use ObserveModule, only: ObserveType + use ConstantsModule, only: LENOBSNAME, LENBIGLINE + use ObserveModule, only: ObserveType use ObsOutputListModule, only: ObsOutputListType - use ObsOutputModule, only: ObsOutputType - use TdisModule, only: totim + use ObsOutputModule, only: ObsOutputType + use TdisModule, only: totim implicit none @@ -32,16 +32,16 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) ! -------------------------------------------------------------------------- implicit none ! -- dummy - character(len=*), intent(in) :: fmtc - type(ObserveType), intent(inout) :: obsrv + character(len=*), intent(in) :: fmtc + type(ObserveType), intent(inout) :: obsrv type(ObsOutputListType), pointer, intent(inout) :: obsOutputList - real(DP), intent(in) :: value + real(DP), intent(in) :: value ! -- local - integer(I4B) :: indx - integer(I4B) :: nunit - character(len=50) :: cval + integer(I4B) :: indx + integer(I4B) :: nunit + character(len=50) :: cval character(len=LENOBSNAME), pointer :: linout => null() - type(ObsOutputType), pointer :: ObsOutput => null() + type(ObsOutputType), pointer :: ObsOutput => null() !--------------------------------------------------------------------------- ! -- format for totim 10 format(G20.13) @@ -52,13 +52,13 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) ObsOutput => obsOutputList%Get(indx) linout => obsOutput%lineout if (linout == '') then - write(linout,10) totim - write(cval,10) totim - write(nunit, '(a)', advance='NO') trim(adjustl(cval)) - endif + write (linout, 10) totim + write (cval, 10) totim + write (nunit, '(a)', advance='NO') trim(adjustl(cval)) + end if ! -- append value to output line - write(cval,fmtc)value - write(nunit, '(a,a)', advance='NO') ',', trim(adjustl(cval)) + write (cval, fmtc) value + write (nunit, '(a,a)', advance='NO') ',', trim(adjustl(cval)) ! ! -- return return @@ -86,11 +86,11 @@ subroutine write_unfmtd_cont(obsrv, iprec, obsOutputList, value) type(ObsOutputListType), pointer, intent(inout) :: obsOutputList real(DP), intent(in) :: value ! -- local - integer(I4B) :: indx, nunit + integer(I4B) :: indx, nunit character(len=LENOBSNAME), pointer :: linout => null() - real(real32) :: totimsngl, valsngl - real(real64) :: totimdbl, valdbl - type(ObsOutputType), pointer :: obsOutput => null() + real(real32) :: totimsngl, valsngl + real(real64) :: totimdbl, valdbl + type(ObsOutputType), pointer :: obsOutput => null() !--------------------------------------------------------------------------- ! -- formats 10 format(G20.13) @@ -101,23 +101,23 @@ subroutine write_unfmtd_cont(obsrv, iprec, obsOutputList, value) obsOutput => obsOutputList%Get(indx) linout => obsOutput%lineout if (linout == '') then - write(linout,10)totim + write (linout, 10) totim if (iprec == 1) then totimsngl = real(totim, real32) - write(nunit)totimsngl + write (nunit) totimsngl elseif (iprec == 2) then totimdbl = totim - write(nunit)totimdbl - endif - endif + write (nunit) totimdbl + end if + end if ! -- write value to unformatted output if (iprec == 1) then valsngl = real(value, real32) - write(nunit)valsngl + write (nunit) valsngl elseif (iprec == 2) then valdbl = value - write(nunit)valdbl - endif + write (nunit) valdbl + end if ! ! -- return return diff --git a/src/Utilities/Observation/Observe.f90 b/src/Utilities/Observation/Observe.f90 index e8f0a732653..cd34726e074 100644 --- a/src/Utilities/Observation/Observe.f90 +++ b/src/Utilities/Observation/Observe.f90 @@ -11,18 +11,18 @@ !----------------------------------------------------------------------- module ObserveModule - use KindModule, only: DP, I4B - use BaseDisModule, only: DisBaseType - use ConstantsModule, only: LENBOUNDNAME, LENOBSNAME, LENOBSTYPE, & - MAXOBSTYPES, DNODATA, DZERO - use TableModule, only: TableType - use InputOutputModule, only: urword - use ListModule, only: ListType - use SimModule, only: store_warning, store_error, & - store_error_unit - use TdisModule, only: totim, totalsimtime + use KindModule, only: DP, I4B + use BaseDisModule, only: DisBaseType + use ConstantsModule, only: LENBOUNDNAME, LENOBSNAME, LENOBSTYPE, & + MAXOBSTYPES, DNODATA, DZERO + use TableModule, only: TableType + use InputOutputModule, only: urword + use ListModule, only: ListType + use SimModule, only: store_warning, store_error, & + store_error_unit + use TdisModule, only: totim, totalsimtime use ArrayHandlersModule, only: ExpandArrayWrapper - + implicit none private @@ -68,11 +68,11 @@ module ObserveModule type(ObsDataType), pointer, private :: obsDatum => null() contains ! -- Public procedures - procedure, public :: ResetCurrent - procedure, public :: WriteTo - procedure, public :: AddObsIndex - procedure, public :: ResetObsIndex - procedure, public :: da + procedure, public :: ResetCurrent + procedure, public :: WriteTo + procedure, public :: AddObsIndex + procedure, public :: ResetObsIndex + procedure, public :: da end type ObserveType type :: ObsDataType @@ -96,10 +96,10 @@ subroutine ProcessIdSub(obsrv, dis, inunitobs, iout) import :: ObserveType import :: DisBaseType ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout end subroutine ProcessIdSub end interface @@ -143,21 +143,21 @@ subroutine WriteTo(this, obstab, btagfound, fnamein) if (len_trim(btagfound) > 12) then tag = btagfound(1:12) else - write(tag, '(a12)') btagfound + write (tag, '(a12)') btagfound end if ! ! -- write fnamein to fnameout if (len_trim(fnamein) > 80) then fnameout = fnamein(1:80) else - write(fnameout, '(a80)') fnamein + write (fnameout, '(a80)') fnamein end if ! ! -- write data to observation table call obstab%add_term(this%Name) - call obstab%add_term(tag // trim(this%ObsTypeId)) + call obstab%add_term(tag//trim(this%ObsTypeId)) call obstab%add_term('ALL TIMES') - call obstab%add_term('"' // trim(this%IDstring) // '"') + call obstab%add_term('"'//trim(this%IDstring)//'"') call obstab%add_term(fnameout) ! ! -- return @@ -179,11 +179,11 @@ subroutine ResetObsIndex(this) ! ! -- Deallocate observation index array, if necessary if (allocated(this%indxbnds)) then - deallocate(this%indxbnds) + deallocate (this%indxbnds) end if ! ! -- Allocate observation index array to size 0 - allocate(this%indxbnds(0)) + allocate (this%indxbnds(0)) ! ! -- return return @@ -192,7 +192,7 @@ end subroutine ResetObsIndex subroutine AddObsIndex(this, indx) ! ************************************************************************** ! AddObsIndex -- Add the observation index to the observation index array -! (indbnds). The observation index count (indxbnds_count) +! (indbnds). The observation index count (indxbnds_count) ! is also incremented by one and the observation index array ! is expanded, if necessary. ! ************************************************************************** @@ -226,7 +226,7 @@ subroutine da(this) ! -- dummy class(ObserveType), intent(inout) :: this if (allocated(this%indxbnds)) then - deallocate(this%indxbnds) + deallocate (this%indxbnds) end if ! ! -- return @@ -245,13 +245,13 @@ subroutine ConstructObservation(newObservation, defLine, numunit, & ! SPECIFICATIONS: ! -------------------------------------------------------------------------- ! -- dummy variables - type(ObserveType), pointer :: newObservation - character(len=*), intent(in) :: defLine - integer(I4B), intent(in) :: numunit ! Output unit number - logical, intent(in) :: formatted ! Formatted output? - integer(I4B), intent(in) :: indx ! Index in ObsOutput array + type(ObserveType), pointer :: newObservation + character(len=*), intent(in) :: defLine + integer(I4B), intent(in) :: numunit ! Output unit number + logical, intent(in) :: formatted ! Formatted output? + integer(I4B), intent(in) :: indx ! Index in ObsOutput array type(ObsDataType), dimension(:), pointer, intent(in) :: obsData - integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: inunit ! -- local real(DP) :: r integer(I4B) :: i, icol, iout, istart, istop, n @@ -262,8 +262,8 @@ subroutine ConstructObservation(newObservation, defLine, numunit, & icol = 1 ! ! -- Allocate an ObserveType object. - allocate(newObservation) - allocate(newObservation%indxbnds(0)) + allocate (newObservation) + allocate (newObservation%indxbnds(0)) ! ! -- Set indxbnds_count to 0 newObservation%indxbnds_count = 0 @@ -272,22 +272,22 @@ subroutine ConstructObservation(newObservation, defLine, numunit, & ! contents of defLine. ! ! -- Get observation name and store it - call urword(defLine,icol,istart,istop,1,n,r,iout,inunit) + call urword(defLine, icol, istart, istop, 1, n, r, iout, inunit) newObservation%Name = defLine(istart:istop) ! ! -- Get observation type, convert it to uppercase, and store it. - call urword(defLine,icol,istart,istop,1,n,r,iout,inunit) + call urword(defLine, icol, istart, istop, 1, n, r, iout, inunit) newObservation%ObsTypeId = defLine(istart:istop) ! ! -- Look up package ID for this observation type and store it - do i=1,MAXOBSTYPES + do i = 1, MAXOBSTYPES if (obsData(i)%ObsTypeID == newObservation%ObsTypeId) then newObservation%obsDatum => obsData(i) exit elseif (obsData(i)%ObsTypeID == '') then exit - endif - enddo + end if + end do ! ! -- Remaining text is ID [and ID2]; store the remainder of the string istart = istop + 1 @@ -321,7 +321,7 @@ end function CastAsObserveType subroutine AddObsToList(list, obs) ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(ObserveType), pointer, intent(inout) :: obs ! -- local class(*), pointer :: obj @@ -332,11 +332,11 @@ subroutine AddObsToList(list, obs) return end subroutine AddObsToList - function GetObsFromList(list, idx) result (res) + function GetObsFromList(list, idx) result(res) ! -- dummy type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(ObserveType), pointer :: res + integer(I4B), intent(in) :: idx + type(ObserveType), pointer :: res ! -- local class(*), pointer :: obj ! diff --git a/src/Utilities/OpenSpec.f90 b/src/Utilities/OpenSpec.f90 index 224b6680cc2..2be8d7bf0d7 100644 --- a/src/Utilities/OpenSpec.f90 +++ b/src/Utilities/OpenSpec.f90 @@ -4,7 +4,7 @@ module OpenSpecModule ! specifiers is not included in ANSI FORTRAN 77. The included ! specifiers are ACCESS, FORM and ACTION. ! - CHARACTER(len=20) :: ACCESS,FORM,ACTION(2) + CHARACTER(len=20) :: ACCESS, FORM, ACTION(2) ! ! ! Specifiers for OPEN statements for unformatted files, which are @@ -15,14 +15,14 @@ module OpenSpecModule ! ! Standard Fortran -- Use unless there is a reason to do otherwise. ! DATA ACCESS/'SEQUENTIAL'/ - DATA ACCESS/'STREAM'/ + DATA ACCESS/'STREAM'/ ! ! ! FORM specifier -- ! ! Standard Fortran, which results in vendor dependent (non-portable) ! files. Use unless there is a reason to do otherwise. - DATA FORM/'UNFORMATTED'/ + DATA FORM/'UNFORMATTED'/ ! ! Non-standard Fortran that causes code compiled by Compaq (Digital) ! Fortran on personal computers to use unstructured non-formatted @@ -41,7 +41,7 @@ module OpenSpecModule ! ! Standard Fortran 90 and 95 -- Use unless there is a reason to do ! otherwise. - DATA (ACTION(IACT),IACT=1,2)/'READ','READWRITE'/ + DATA(ACTION(IACT), IACT=1, 2)/'READ', 'READWRITE'/ ! ! Non-standard Fortran that causes code compiled by the Lahey LF90 ! compiler to create files that can be shared. For use when parallel @@ -49,4 +49,4 @@ module OpenSpecModule ! while the program is running. ! DATA (ACTION(I),I=1,2)/'READ,DENYWRITE','READWRITE,DENYNONE'/ ! -end module OpenSpecModule \ No newline at end of file +end module OpenSpecModule diff --git a/src/Utilities/OutputControl/OutputControl.f90 b/src/Utilities/OutputControl/OutputControl.f90 index d6591f6fb7f..23a97e25748 100644 --- a/src/Utilities/OutputControl/OutputControl.f90 +++ b/src/Utilities/OutputControl/OutputControl.f90 @@ -7,13 +7,13 @@ !< module OutputControlModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENMEMPATH - use SimVariablesModule, only: errmsg + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENMEMPATH + use SimVariablesModule, only: errmsg use OutputControlDataModule, only: OutputControlDataType, ocd_cr - use BlockParserModule, only: BlockParserType + use BlockParserModule, only: BlockParserType use InputOutputModule, only: GetUnit, openfile - + implicit none private public OutputControlType, oc_cr @@ -22,16 +22,17 @@ module OutputControlModule !! !! Generalized output control package !< - type OutputControlType - character(len=LENMEMPATH) :: memoryPath !< path to data stored in the memory manager - character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model - integer(I4B), pointer :: inunit => null() !< unit number for input file - integer(I4B), pointer :: iout => null() !< unit number for output file - integer(I4B), pointer :: ibudcsv => null() !< unit number for budget csv output file - integer(I4B), pointer :: iperoc => null() !< stress period number for next output control - integer(I4B), pointer :: iocrep => null() !< output control repeat flag (period 0 step 0) - type(OutputControlDataType), dimension(:), pointer, contiguous :: ocdobj => null() !< output control objects - type(BlockParserType) :: parser + type OutputControlType + character(len=LENMEMPATH) :: memoryPath !< path to data stored in the memory manager + character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model + integer(I4B), pointer :: inunit => null() !< unit number for input file + integer(I4B), pointer :: iout => null() !< unit number for output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for budget csv output file + integer(I4B), pointer :: iperoc => null() !< stress period number for next output control + integer(I4B), pointer :: iocrep => null() !< output control repeat flag (period 0 step 0) + type(OutputControlDataType), dimension(:), & + pointer, contiguous :: ocdobj => null() !< output control objects + type(BlockParserType) :: parser contains procedure :: oc_df procedure :: oc_rp @@ -45,7 +46,7 @@ module OutputControlModule procedure :: set_print_flag end type OutputControlType - contains +contains !> @ brief Create OutputControlType !! @@ -55,13 +56,13 @@ module OutputControlModule !< subroutine oc_cr(ocobj, name_model, inunit, iout) ! -- dummy - type(OutputControlType), pointer :: ocobj !< OutputControlType object - character(len=*), intent(in) :: name_model !< name of the model - integer(I4B), intent(in) :: inunit !< unit number for input - integer(I4B), intent(in) :: iout !< unit number for output + type(OutputControlType), pointer :: ocobj !< OutputControlType object + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< unit number for input + integer(I4B), intent(in) :: iout !< unit number for output ! ! -- Create the object - allocate(ocobj) + allocate (ocobj) ! ! -- Allocate scalars call ocobj%allocate_scalars(name_model) @@ -84,7 +85,7 @@ end subroutine oc_cr !< subroutine oc_df(this) ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! ! -- Return return @@ -97,11 +98,11 @@ end subroutine oc_df !< subroutine oc_rp(this) ! -- modules - use TdisModule, only: kper, nper - use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! -- local integer(I4B) :: ierr, ival, ipos logical :: isfound, found, endOfBlock @@ -110,19 +111,19 @@ subroutine oc_rp(this) character(len=LINELENGTH) :: printsave class(OutputControlDataType), pointer :: ocdobjptr ! -- formats - character(len=*), parameter :: fmtboc = & - "(1X,/1X,'BEGIN READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" - character(len=*), parameter :: fmteoc = & - "(/,1X,'END READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" - character(len=*), parameter :: fmterr = & - "(' ERROR READING OUTPUT CONTROL PERIOD BLOCK: ')" - character(len=*), parameter :: fmtroc = & - "(1X,/1X,'OUTPUT CONTROL FOR STRESS PERIOD ',I0, & - &' IS REPEATED USING SETTINGS FROM A PREVIOUS STRESS PERIOD.')" - character(len=*), parameter :: fmtpererr = & - "(1x,'CURRENT STRESS PERIOD GREATER THAN PERIOD IN OUTPUT CONTROL.')" - character(len=*), parameter :: fmtpererr2 = & - "(1x,'CURRENT STRESS PERIOD: ',I0,' SPECIFIED STRESS PERIOD: ',I0)" + character(len=*), parameter :: fmtboc = & + &"(1X,/1X,'BEGIN READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" + character(len=*), parameter :: fmteoc = & + &"(/,1X,'END READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" + character(len=*), parameter :: fmterr = & + &"(' ERROR READING OUTPUT CONTROL PERIOD BLOCK: ')" + character(len=*), parameter :: fmtroc = & + "(1X,/1X,'OUTPUT CONTROL FOR STRESS PERIOD ',I0, & + &' IS REPEATED USING SETTINGS FROM A PREVIOUS STRESS PERIOD.')" + character(len=*), parameter :: fmtpererr = & + &"(1x,'CURRENT STRESS PERIOD GREATER THAN PERIOD IN OUTPUT CONTROL.')" + character(len=*), parameter :: fmtpererr2 = & + &"(1x,'CURRENT STRESS PERIOD: ',I0,' SPECIFIED STRESS PERIOD: ',I0)" ! ! -- Read next block header if kper greater than last one read if (this%iperoc < kper) then @@ -134,38 +135,38 @@ subroutine oc_rp(this) ! -- If end of file, set iperoc past kper, else parse line if (ierr < 0) then this%iperoc = nper + 1 - write(this%iout, '(/,1x,a)') 'END OF FILE DETECTED IN OUTPUT CONTROL.' - write(this%iout, '(1x,a)') 'CURRENT OUTPUT CONTROL SETTINGS WILL BE ' - write(this%iout, '(1x,a)') 'REPEATED UNTIL THE END OF THE SIMULATION.' + write (this%iout, '(/,1x,a)') 'END OF FILE DETECTED IN OUTPUT CONTROL.' + write (this%iout, '(1x,a)') 'CURRENT OUTPUT CONTROL SETTINGS WILL BE ' + write (this%iout, '(1x,a)') 'REPEATED UNTIL THE END OF THE SIMULATION.' else ! ! -- Read period number ival = this%parser%GetInteger() ! ! -- Check to see if this is a valid kper - if(ival <= 0 .or. ival > nper) then - write(ermsg, '(a,i0)') 'PERIOD NOT VALID IN OUTPUT CONTROL: ', ival + if (ival <= 0 .or. ival > nper) then + write (ermsg, '(a,i0)') 'PERIOD NOT VALID IN OUTPUT CONTROL: ', ival call store_error(ermsg) - write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) + write (ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) call store_error(ermsg) - endif + end if ! ! -- Check to see if specified is less than kper - if(ival < kper) then - write(ermsg, fmtpererr) + if (ival < kper) then + write (ermsg, fmtpererr) call store_error(ermsg) - write(ermsg, fmtpererr2) kper, ival + write (ermsg, fmtpererr2) kper, ival call store_error(ermsg) - write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) + write (ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) call store_error(ermsg) - endif + end if ! ! -- Stop or set iperoc and continue - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if this%iperoc = ival - endif + end if end if ! ! -- Read the stress period block @@ -175,10 +176,10 @@ subroutine oc_rp(this) do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) call ocdobjptr%psmobj%init() - enddo + end do ! ! -- Output control time step matches simulation time step. - write(this%iout,fmtboc) this%iperoc + write (this%iout, fmtboc) this%iperoc ! ! -- loop to read records recordloop: do @@ -199,33 +200,33 @@ subroutine oc_rp(this) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(keyword2 == trim(ocdobjptr%cname)) then + if (keyword2 == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo + end if + end do if (.not. found) then call this%parser%GetCurrentLine(line) - write(ermsg, fmterr) + write (ermsg, fmterr) call store_error(ermsg) call store_error('UNRECOGNIZED KEYWORD: '//keyword2) call store_error(trim(line)) call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetRemainingLine(line) - call ocdobjptr%psmobj%rp(trim(printsave)//' '//line, & + call ocdobjptr%psmobj%rp(trim(printsave)//' '//line, & this%iout) call ocdobjptr%ocd_rp_check(this%parser%iuactive) ! ! -- End of recordloop - enddo recordloop - write(this%iout,fmteoc) this%iperoc + end do recordloop + write (this%iout, fmteoc) this%iperoc else ! ! -- Write message that output control settings are from a previous ! stress period. - write(this%iout, fmtroc) kper - endif + write (this%iout, fmtroc) kper + end if ! ! -- return return @@ -241,11 +242,11 @@ subroutine oc_ot(this, ipflg) ! -- modules use TdisModule, only: kstp, endofperiod ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - integer(I4B), intent(inout) :: ipflg !< flag indicating if data was printed + class(OutputControlType) :: this !< OutputControlType object + integer(I4B), intent(inout) :: ipflg !< flag indicating if data was printed ! -- local integer(I4B) :: ipos - type(OutputControlDataType), pointer :: ocdobjptr + type(OutputControlDataType), pointer :: ocdobjptr ! ! -- Clear printout flag(ipflg). This flag indicates that an array was ! printed to the listing file. @@ -254,7 +255,7 @@ subroutine oc_ot(this, ipflg) do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) call ocdobjptr%ocd_ot(ipflg, kstp, endofperiod, this%iout) - enddo + end do ! ! -- Return return @@ -269,16 +270,16 @@ subroutine oc_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! -- local integer(I4B) :: i ! do i = 1, size(this%ocdobj) call this%ocdobj(i)%ocd_da() - enddo - deallocate(this%ocdobj) + end do + deallocate (this%ocdobj) ! - deallocate(this%name_model) + deallocate (this%name_model) call mem_deallocate(this%inunit) call mem_deallocate(this%iout) call mem_deallocate(this%ibudcsv) @@ -299,12 +300,12 @@ subroutine allocate_scalars(this, name_model) use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: name_model !< name of model + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: name_model !< name of model ! this%memoryPath = create_mem_path(name_model, 'OC') ! - allocate(this%name_model) + allocate (this%name_model) call mem_allocate(this%inunit, 'INUNIT', this%memoryPath) call mem_allocate(this%iout, 'IOUT', this%memoryPath) call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath) @@ -332,7 +333,7 @@ subroutine read_options(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! -- local character(len=LINELENGTH) :: keyword character(len=LINELENGTH) :: keyword2 @@ -341,15 +342,15 @@ subroutine read_options(this) integer(I4B) :: ierr integer(I4B) :: ipos logical :: isfound, found, endOfBlock - type(OutputControlDataType), pointer :: ocdobjptr + type(OutputControlDataType), pointer :: ocdobjptr ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(/,1x,a,/)') 'PROCESSING OC OPTIONS' + write (this%iout, '(/,1x,a,/)') 'PROCESSING OC OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -359,34 +360,35 @@ subroutine read_options(this) call this%parser%GetStringCaps(keyword2) if (keyword2 /= 'FILEOUT') then errmsg = "BUDGETCSV must be followed by FILEOUT and then budget & - &csv file name. Found '" // trim(keyword2) // "'." + &csv file name. Found '"//trim(keyword2)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end if call this%parser%GetString(fname) this%ibudcsv = GetUnit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', filstat_opt='REPLACE') + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') found = .true. end if - + if (.not. found) then do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(keyword == trim(ocdobjptr%cname)) then + if (keyword == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo + end if + end do if (.not. found) then - errmsg = "UNKNOWN OC OPTION '" // trim(keyword) // "'." + errmsg = "UNKNOWN OC OPTION '"//trim(keyword)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetRemainingLine(line) call ocdobjptr%set_option(line, this%parser%iuactive, this%iout) end if end do - write(this%iout,'(1x,a)') 'END OF OC OPTIONS' + write (this%iout, '(1x,a)') 'END OF OC OPTIONS' end if ! ! -- return @@ -402,8 +404,8 @@ logical function oc_save(this, cname) ! -- modules use TdisModule, only: kstp, endofperiod ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name ! -- local integer(I4B) :: ipos logical :: found @@ -413,14 +415,14 @@ logical function oc_save(this, cname) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then + if (cname == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo - if(found) then + end if + end do + if (found) then oc_save = ocdobjptr%psmobj%kstp_to_save(kstp, endofperiod) - endif + end if ! ! -- Return return @@ -435,8 +437,8 @@ logical function oc_print(this, cname) ! -- modules use TdisModule, only: kstp, endofperiod ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name ! -- local integer(I4B) :: ipos logical :: found @@ -446,14 +448,14 @@ logical function oc_print(this, cname) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then + if (cname == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo - if(found) then + end if + end do + if (found) then oc_print = ocdobjptr%psmobj%kstp_to_print(kstp, endofperiod) - endif + end if ! ! -- Return return @@ -469,8 +471,8 @@ function oc_save_unit(this, cname) ! -- return integer(I4B) :: oc_save_unit ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name ! -- local integer(I4B) :: ipos logical :: found @@ -480,14 +482,14 @@ function oc_save_unit(this, cname) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then + if (cname == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo - if(found) then + end if + end do + if (found) then oc_save_unit = ocdobjptr%idataun - endif + end if ! ! -- Return return @@ -504,25 +506,25 @@ function set_print_flag(this, cname, icnvg, endofperiod) result(iprint_flag) ! -- return integer(I4B) :: iprint_flag ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name - integer(I4B), intent(in) :: icnvg !< convergence flag - logical, intent(in) :: endofperiod !< end of period logical flag + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name + integer(I4B), intent(in) :: icnvg !< convergence flag + logical, intent(in) :: endofperiod !< end of period logical flag ! -- local ! ! -- default is to not print iprint_flag = 0 ! ! -- if the output control file indicates that cname should be printed - if(this%oc_print(cname)) iprint_flag = 1 + if (this%oc_print(cname)) iprint_flag = 1 ! ! -- if it is not a CONTINUE run, then set to print if not converged if (isimcontinue == 0) then - if(icnvg == 0) iprint_flag = 1 + if (icnvg == 0) iprint_flag = 1 end if ! ! -- if it's the end of the period, then set flag to print - if(endofperiod) iprint_flag = 1 + if (endofperiod) iprint_flag = 1 ! ! -- Return return diff --git a/src/Utilities/OutputControl/OutputControlData.f90 b/src/Utilities/OutputControl/OutputControlData.f90 index 5837980bdbf..adbbeee0ce1 100644 --- a/src/Utilities/OutputControl/OutputControlData.f90 +++ b/src/Utilities/OutputControl/OutputControlData.f90 @@ -7,34 +7,34 @@ !! !< module OutputControlDataModule - - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: print_format - use KindModule, only: DP, I4B, LGP + + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: print_format + use KindModule, only: DP, I4B, LGP use PrintSaveManagerModule, only: PrintSaveManagerType - + implicit none private public OutputControlDataType, ocd_cr - + !> @ brief OutputControlDataType !! !! Object for storing information and determining whether or !! not model data should be printed to a list file or saved to disk. !< type OutputControlDataType - character(len=16), pointer :: cname => null() !< name of variable, such as HEAD - character(len=60), pointer :: cdatafmp => null() !< fortran format for printing - integer(I4B), pointer :: idataun => null() !< fortran unit number for binary output - character(len=1), pointer :: editdesc => null() !< fortran format type (I, G, F, S, E) - integer(I4B), pointer :: nvaluesp => null() !< number of values per line for printing - integer(I4B), pointer :: nwidthp => null() !< width of the number for printing - real(DP), pointer :: dnodata => null() !< no data value - integer(I4B), pointer :: inodata => null() !< integer no data value - real(DP), dimension(:), pointer, contiguous :: dblvec => null() !< pointer to double precision data array - integer(I4B), dimension(:), pointer, contiguous :: intvec => null() !< pointer to integer data array - class(DisBaseType), pointer :: dis => null() !< pointer to discretization package - type(PrintSaveManagerType), pointer :: psmobj => null() !< print/save manager object + character(len=16), pointer :: cname => null() !< name of variable, such as HEAD + character(len=60), pointer :: cdatafmp => null() !< fortran format for printing + integer(I4B), pointer :: idataun => null() !< fortran unit number for binary output + character(len=1), pointer :: editdesc => null() !< fortran format type (I, G, F, S, E) + integer(I4B), pointer :: nvaluesp => null() !< number of values per line for printing + integer(I4B), pointer :: nwidthp => null() !< width of the number for printing + real(DP), pointer :: dnodata => null() !< no data value + integer(I4B), pointer :: inodata => null() !< integer no data value + real(DP), dimension(:), pointer, contiguous :: dblvec => null() !< pointer to double precision data array + integer(I4B), dimension(:), pointer, contiguous :: intvec => null() !< pointer to integer data array + class(DisBaseType), pointer :: dis => null() !< pointer to discretization package + type(PrintSaveManagerType), pointer :: psmobj => null() !< print/save manager object contains procedure :: allocate_scalars procedure :: init_int @@ -44,9 +44,9 @@ module OutputControlDataModule procedure :: ocd_ot procedure :: ocd_da end type OutputControlDataType - - contains - + +contains + !> @ brief Create OutputControlDataType !! !! Create by allocating a new OutputControlDataType object @@ -54,10 +54,10 @@ module OutputControlDataModule !< subroutine ocd_cr(ocdobj) ! -- dummy - type(OutputControlDataType), pointer :: ocdobj !< OutputControlDataType object + type(OutputControlDataType), pointer :: ocdobj !< OutputControlDataType object ! ! -- Create the object - allocate(ocdobj) + allocate (ocdobj) ! ! -- Allocate scalars call ocdobj%allocate_scalars() @@ -65,7 +65,7 @@ subroutine ocd_cr(ocdobj) ! -- Return return end subroutine ocd_cr - + !> @ brief Check OutputControlDataType object !! !! Perform a consistency check @@ -76,28 +76,28 @@ subroutine ocd_rp_check(this, inunit) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - integer(I4B), intent(in) :: inunit !< Unit number for input + class(OutputControlDataType) :: this !< OutputControlDataType object + integer(I4B), intent(in) :: inunit !< Unit number for input ! -- locals character(len=LINELENGTH) :: errmsg ! -- formats - character(len=*), parameter :: fmtocsaveerr = & - "(1X,'REQUESTING TO SAVE ',A,' BUT ',A,' SAVE FILE NOT SPECIFIED. ', & + character(len=*), parameter :: fmtocsaveerr = & + "(1X,'REQUESTING TO SAVE ',A,' BUT ',A,' SAVE FILE NOT SPECIFIED. ', & &A,' SAVE FILE MUST BE SPECIFIED IN OUTPUT CONTROL OPTIONS.')" ! ! -- Check to make sure save file was specified - if(this%psmobj%save_detected) then - if(this%idataun == 0) then - write(errmsg, fmtocsaveerr) trim(adjustl(this%cname)), & - trim(adjustl(this%cname)), & - trim(adjustl(this%cname)) + if (this%psmobj%save_detected) then + if (this%idataun == 0) then + write (errmsg, fmtocsaveerr) trim(adjustl(this%cname)), & + trim(adjustl(this%cname)), & + trim(adjustl(this%cname)) call store_error(errmsg) - endif - endif + end if + end if ! - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error_unit(inunit) - endif + end if ! ! -- return return @@ -111,13 +111,13 @@ end subroutine ocd_rp_check !< subroutine ocd_ot(this, ipflg, kstp, endofperiod, iout, iprint_opt, isav_opt) ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - integer(I4B), intent(inout) :: ipflg !< Flag indicating if something was printed - integer(I4B), intent(in) :: kstp !< Current time step - logical(LGP), intent(in) :: endofperiod !< End of period logical flag - integer(I4B), intent(in) :: iout !< Unit number for output - integer(I4B), optional, intent(in) :: iprint_opt !< Optional print flag override - integer(I4B), optional, intent(in) :: isav_opt !< Optional save flag override + class(OutputControlDataType) :: this !< OutputControlDataType object + integer(I4B), intent(inout) :: ipflg !< Flag indicating if something was printed + integer(I4B), intent(in) :: kstp !< Current time step + logical(LGP), intent(in) :: endofperiod !< End of period logical flag + integer(I4B), intent(in) :: iout !< Unit number for output + integer(I4B), optional, intent(in) :: iprint_opt !< Optional print flag override + integer(I4B), optional, intent(in) :: isav_opt !< Optional save flag override ! -- local integer(I4B) :: iprint integer(I4B) :: idataun @@ -133,39 +133,39 @@ subroutine ocd_ot(this, ipflg, kstp, endofperiod, iout, iprint_opt, isav_opt) if (iprint_opt /= 0) then iprint = 1 ipflg = 1 - endif + end if else - if(this%psmobj%kstp_to_print(kstp, endofperiod)) then + if (this%psmobj%kstp_to_print(kstp, endofperiod)) then iprint = 1 ipflg = 1 - endif - endif + end if + end if ! ! -- determine whether or not to save the array to a file if (present(isav_opt)) then if (isav_opt /= 0) then idataun = this%idataun - endif + end if else - if(this%psmobj%kstp_to_save(kstp, endofperiod)) idataun = this%idataun - endif + if (this%psmobj%kstp_to_save(kstp, endofperiod)) idataun = this%idataun + end if ! ! -- Record double precision array - if(associated(this%dblvec)) & - call this%dis%record_array(this%dblvec, iout, iprint, idataun, & - this%cname, this%cdatafmp, this%nvaluesp, & - this%nwidthp, this%editdesc, this%dnodata) + if (associated(this%dblvec)) & + call this%dis%record_array(this%dblvec, iout, iprint, idataun, & + this%cname, this%cdatafmp, this%nvaluesp, & + this%nwidthp, this%editdesc, this%dnodata) ! ! -- Record integer array (not supported yet) - !if(associated(this%intvec)) & - !call this%dis%record_array(this%intvec, iout, iprint, idataun, & - ! this%cname, this%cdatafmp, this%nvaluesp, & + !if(associated(this%intvec)) & + !call this%dis%record_array(this%intvec, iout, iprint, idataun, & + ! this%cname, this%cdatafmp, this%nvaluesp, & ! this%nwidthp, this%editdesc, this%inodata) ! ! -- Return return end subroutine ocd_ot - + !> @ brief Deallocate OutputControlDataType !! !! Deallocate members of this type @@ -177,37 +177,37 @@ subroutine ocd_da(this) ! -- dummy class(OutputControlDataType) :: this ! - ! -- deallocate - deallocate(this%cname) - deallocate(this%cdatafmp) - deallocate(this%idataun) - deallocate(this%editdesc) - deallocate(this%nvaluesp) - deallocate(this%nwidthp) - deallocate(this%dnodata) - deallocate(this%inodata) - deallocate(this%psmobj) + ! -- deallocate + deallocate (this%cname) + deallocate (this%cdatafmp) + deallocate (this%idataun) + deallocate (this%editdesc) + deallocate (this%nvaluesp) + deallocate (this%nwidthp) + deallocate (this%dnodata) + deallocate (this%inodata) + deallocate (this%psmobj) ! ! -- return return - end subroutine ocd_da - + end subroutine ocd_da + !> @ brief Initialize this OutputControlDataType as double precision data !! !! Initialize this object as a double precision data type !! !< - subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & + subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & dnodata) ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - character(len=*), intent(in) :: cname !< Name of variable - real(DP), dimension(:), pointer, contiguous, intent(in) :: dblvec !< Data array that will be managed by this object - class(DisBaseType), pointer, intent(in) :: dis !< Discretization package - character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager - character(len=*), intent(in) :: cdeffmp !< String for print format - integer(I4B), intent(in) :: iout !< Unit number for output - real(DP), intent(in) :: dnodata !< No data value + class(OutputControlDataType) :: this !< OutputControlDataType object + character(len=*), intent(in) :: cname !< Name of variable + real(DP), dimension(:), pointer, contiguous, intent(in) :: dblvec !< Data array that will be managed by this object + class(DisBaseType), pointer, intent(in) :: dis !< Discretization package + character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager + character(len=*), intent(in) :: cdeffmp !< String for print format + integer(I4B), intent(in) :: iout !< Unit number for output + real(DP), intent(in) :: dnodata !< No data value ! this%cname = cname this%dblvec => dblvec @@ -215,29 +215,29 @@ subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & this%dnodata = dnodata call this%psmobj%init() if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) - call print_format(cdeffmp, this%cdatafmp, & + call print_format(cdeffmp, this%cdatafmp, & this%editdesc, this%nvaluesp, this%nwidthp, 0) ! ! -- return return end subroutine init_dbl - + !> @ brief Initialize this OutputControlDataType as integer data !! !! Initialize this object as an integer data type !! !< - subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & + subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & inodata) ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - character(len=*), intent(in) :: cname !< Name of variable - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: intvec !< Data array that will be managed by this object - class(DisBaseType), pointer, intent(in) :: dis !< Discretization package - character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager - character(len=*), intent(in) :: cdeffmp !< String for print format - integer(I4B), intent(in) :: iout !< Unit number for output - integer(I4B), intent(in) :: inodata !< No data value + class(OutputControlDataType) :: this !< OutputControlDataType object + character(len=*), intent(in) :: cname !< Name of variable + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: intvec !< Data array that will be managed by this object + class(DisBaseType), pointer, intent(in) :: dis !< Discretization package + character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager + character(len=*), intent(in) :: cdeffmp !< String for print format + integer(I4B), intent(in) :: iout !< Unit number for output + integer(I4B), intent(in) :: inodata !< No data value ! this%cname = cname this%intvec => intvec @@ -246,13 +246,13 @@ subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & this%editdesc = 'I' call this%psmobj%init() if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) - call print_format(cdeffmp, this%cdatafmp, this%editdesc, this%nvaluesp, & + call print_format(cdeffmp, this%cdatafmp, this%editdesc, this%nvaluesp, & this%nwidthp, 0) ! ! -- return return - end subroutine init_int - + end subroutine init_int + !> @ brief Allocate OutputControlDataType members !! !! Allocate and initialize member variables @@ -262,17 +262,17 @@ subroutine allocate_scalars(this) ! -- modules use ConstantsModule, only: DZERO ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object + class(OutputControlDataType) :: this !< OutputControlDataType object ! - allocate(this%cname) - allocate(this%cdatafmp) - allocate(this%idataun) - allocate(this%editdesc) - allocate(this%nvaluesp) - allocate(this%nwidthp) - allocate(this%dnodata) - allocate(this%inodata) - allocate(this%psmobj) + allocate (this%cname) + allocate (this%cdatafmp) + allocate (this%idataun) + allocate (this%editdesc) + allocate (this%nvaluesp) + allocate (this%nwidthp) + allocate (this%dnodata) + allocate (this%inodata) + allocate (this%psmobj) ! this%cname = '' this%cdatafmp = '' @@ -285,8 +285,8 @@ subroutine allocate_scalars(this) ! ! -- return return - end subroutine allocate_scalars - + end subroutine allocate_scalars + !> @ brief Set options for this object based on an input string !! !! Set FILEOUT and PRINT_FORMAT options for this object. @@ -294,47 +294,47 @@ end subroutine allocate_scalars !< subroutine set_option(this, linein, inunit, iout) ! -- modules - use ConstantsModule, only: MNORMAL + use ConstantsModule, only: MNORMAL use OpenSpecModule, only: access, form use InputOutputModule, only: urword, getunit, openfile use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - character(len=*), intent(in) :: linein !< Character string with options - integer(I4B), intent(in) :: inunit !< Unit number for input - integer(I4B), intent(in) :: iout !< Unit number for output + class(OutputControlDataType) :: this !< OutputControlDataType object + character(len=*), intent(in) :: linein !< Character string with options + integer(I4B), intent(in) :: inunit !< Unit number for input + integer(I4B), intent(in) :: iout !< Unit number for output ! -- local character(len=len(linein)) :: line integer(I4B) :: lloc, istart, istop, ival real(DP) :: rval ! -- format - character(len=*),parameter :: fmtocsave = & - "(4X,A,' INFORMATION WILL BE WRITTEN TO:', & - &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" + character(len=*), parameter :: fmtocsave = & + "(4X,A,' INFORMATION WILL BE WRITTEN TO:', & + &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" ! line(:) = linein(:) lloc = 1 call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('FILEOUT') + select case (line(istart:istop)) + case ('FILEOUT') call urword(line, lloc, istart, istop, 0, ival, rval, 0, 0) this%idataun = getunit() - write(iout, fmtocsave) trim(adjustl(this%cname)), this%idataun, & - line(istart:istop) - call openfile(this%idataun, iout, line(istart:istop), 'DATA(BINARY)', & + write (iout, fmtocsave) trim(adjustl(this%cname)), this%idataun, & + line(istart:istop) + call openfile(this%idataun, iout, line(istart:istop), 'DATA(BINARY)', & form, access, 'REPLACE', MNORMAL) - case('PRINT_FORMAT') + case ('PRINT_FORMAT') call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - call print_format(line(istart:), this%cdatafmp, this%editdesc, & + call print_format(line(istart:), this%cdatafmp, this%editdesc, & this%nvaluesp, this%nwidthp, inunit) case default - call store_error('Looking for FILEOUT or PRINT_FORMAT. Found:') - call store_error(trim(adjustl(line))) - call store_error_unit(inunit) + call store_error('Looking for FILEOUT or PRINT_FORMAT. Found:') + call store_error(trim(adjustl(line))) + call store_error_unit(inunit) end select ! ! -- return return - end subroutine set_option - + end subroutine set_option + end module OutputControlDataModule diff --git a/src/Utilities/OutputControl/PrintSaveManager.f90 b/src/Utilities/OutputControl/PrintSaveManager.f90 index 064a3585766..2aa1fcc811f 100644 --- a/src/Utilities/OutputControl/PrintSaveManager.f90 +++ b/src/Utilities/OutputControl/PrintSaveManager.f90 @@ -28,17 +28,17 @@ !! !< module PrintSaveManagerModule - + use KindModule, only: DP, I4B, LGP use ArrayHandlersModule, only: expandarray use SimVariablesModule, only: errmsg - use SimModule, only: store_error - use InputOutputModule, only: urword - + use SimModule, only: store_error + use InputOutputModule, only: urword + implicit none private public :: PrintSaveManagerType - + !> @ brief PrintSaveManagerType !! !! Object for storing information and determining whether or @@ -47,25 +47,25 @@ module PrintSaveManagerModule type :: PrintSaveManagerType integer(I4B), allocatable, dimension(:) :: kstp_list_print integer(I4B), allocatable, dimension(:) :: kstp_list_save - integer(I4B) :: ifreq_print - integer(I4B) :: ifreq_save - logical :: print_first - logical :: save_first - logical :: print_last - logical :: save_last - logical :: print_all - logical :: save_all - logical :: save_detected - logical :: print_detected + integer(I4B) :: ifreq_print + integer(I4B) :: ifreq_save + logical :: print_first + logical :: save_first + logical :: print_last + logical :: save_last + logical :: print_all + logical :: save_all + logical :: save_detected + logical :: print_detected contains procedure :: init procedure :: rp procedure :: kstp_to_print procedure :: kstp_to_save end type PrintSaveManagerType - - contains - + +contains + !> @ brief Initialize PrintSaveManager !! !! Initializes variables of a PrintSaveManagerType @@ -73,13 +73,13 @@ module PrintSaveManagerModule !< subroutine init(this) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object to initialize + class(PrintSaveManagerType) :: this !< psm object to initialize ! ! -- Initialize members to their defaults - if(allocated(this%kstp_list_print)) deallocate(this%kstp_list_print) - if(allocated(this%kstp_list_save)) deallocate(this%kstp_list_save) - allocate(this%kstp_list_print(0)) - allocate(this%kstp_list_save(0)) + if (allocated(this%kstp_list_print)) deallocate (this%kstp_list_print) + if (allocated(this%kstp_list_save)) deallocate (this%kstp_list_save) + allocate (this%kstp_list_print(0)) + allocate (this%kstp_list_save(0)) this%ifreq_print = 0 this%ifreq_save = 0 this%save_first = .false. @@ -94,18 +94,18 @@ subroutine init(this) ! -- return return end subroutine init - + !> @ brief Read and prepare for PrintSaveManager !! - !! Parse information in the line and assign settings for the + !! Parse information in the line and assign settings for the !! PrintSaveManagerType. !! !< subroutine rp(this, linein, iout) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object - character(len=*), intent(in) :: linein !< character line of information - integer(I4B), intent(in) :: iout !< unit number of output file + class(PrintSaveManagerType) :: this !< psm object + character(len=*), intent(in) :: linein !< character line of information + integer(I4B), intent(in) :: iout !< unit number of output file ! -- local character(len=len(linein)) :: line logical lp, ls @@ -114,9 +114,9 @@ subroutine rp(this, linein, iout) real(DP) :: rval ! -- formats character(len=*), parameter :: fmt_steps = & - "(6x,'THE FOLLOWING STEPS WILL BE ',A,': ',50(I0,' '))" + &"(6x,'THE FOLLOWING STEPS WILL BE ',A,': ',50(I0,' '))" character(len=*), parameter :: fmt_freq = & - "(6x,'THE FOLLOWING FREQUENCY WILL BE ',A,': ',I0)" + &"(6x,'THE FOLLOWING FREQUENCY WILL BE ',A,': ',I0)" ! ! -- Set the values based on line ! -- Get keyword to use in assignment @@ -127,15 +127,15 @@ subroutine rp(this, linein, iout) ! -- set dimension for print or save lp = .false. ls = .false. - select case(line(istart:istop)) - case('PRINT') + select case (line(istart:istop)) + case ('PRINT') lp = .true. - case('SAVE') + case ('SAVE') ls = .true. case default - write(errmsg, '(2a)') & - 'Looking for PRINT or SAVE. Found:', trim(adjustl(line)) - call store_error(errmsg, terminate=.TRUE.) + write (errmsg, '(2a)') & + 'Looking for PRINT or SAVE. Found:', trim(adjustl(line)) + call store_error(errmsg, terminate=.TRUE.) end select ! ! -- set member variables @@ -144,64 +144,64 @@ subroutine rp(this, linein, iout) ! ! -- set the steps to print or save call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('ALL') - if(lp) then + select case (line(istart:istop)) + case ('ALL') + if (lp) then this%print_all = .true. - if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE PRINTED' - endif - if(ls) then + if (iout > 0) write (iout, "(6x,a)") 'ALL TIME STEPS WILL BE PRINTED' + end if + if (ls) then this%save_all = .true. - if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE SAVED' - endif - case('STEPS') + if (iout > 0) write (iout, "(6x,a)") 'ALL TIME STEPS WILL BE SAVED' + end if + case ('STEPS') listsearch: do call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) - if(ival > 0) then - if(lp) then + if (ival > 0) then + if (lp) then n = size(this%kstp_list_print) call expandarray(this%kstp_list_print) this%kstp_list_print(n + 1) = ival - endif - if(ls) then + end if + if (ls) then n = size(this%kstp_list_save) call expandarray(this%kstp_list_save) this%kstp_list_save(n + 1) = ival - endif + end if cycle listsearch - endif + end if exit listsearch - enddo listsearch - if(iout > 0) then - if(lp) write(iout, fmt_steps) 'PRINTED', this%kstp_list_print - if(ls) write(iout, fmt_steps) 'SAVED', this%kstp_list_save - endif - case('FREQUENCY') + end do listsearch + if (iout > 0) then + if (lp) write (iout, fmt_steps) 'PRINTED', this%kstp_list_print + if (ls) write (iout, fmt_steps) 'SAVED', this%kstp_list_save + end if + case ('FREQUENCY') call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) - if(lp) this%ifreq_print = ival - if(ls) this%ifreq_save = ival - if(iout > 0) then - if(lp) write(iout, fmt_freq) 'PRINTED', this%ifreq_print - if(ls) write(iout, fmt_freq) 'SAVED', this%ifreq_save - endif - case('FIRST') - if(lp) then + if (lp) this%ifreq_print = ival + if (ls) this%ifreq_save = ival + if (iout > 0) then + if (lp) write (iout, fmt_freq) 'PRINTED', this%ifreq_print + if (ls) write (iout, fmt_freq) 'SAVED', this%ifreq_save + end if + case ('FIRST') + if (lp) then this%print_first = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE PRINTED' - endif - if(ls) then + if (iout > 0) write (iout, "(6x,a)") 'THE FIRST TIME STEP WILL BE PRINTED' + end if + if (ls) then this%save_first = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE SAVED' - endif - case('LAST') - if(lp) then + if (iout > 0) write (iout, "(6x,a)") 'THE FIRST TIME STEP WILL BE SAVED' + end if + case ('LAST') + if (lp) then this%print_last = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE PRINTED' - endif - if(ls) then + if (iout > 0) write (iout, "(6x,a)") 'THE LAST TIME STEP WILL BE PRINTED' + end if + if (ls) then this%save_last = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE SAVED' - endif + if (iout > 0) write (iout, "(6x,a)") 'THE LAST TIME STEP WILL BE SAVED' + end if case default write (errmsg, '(2a)') & 'Looking for ALL, STEPS, FIRST, LAST, OR FREQUENCY. Found: ', & @@ -212,73 +212,73 @@ subroutine rp(this, linein, iout) ! -- return return end subroutine rp - + !> @ brief Determine if it is time to print the data !! - !! Determine if data should be printed based on kstp and endofperiod + !! Determine if data should be printed based on kstp and endofperiod !! !< logical function kstp_to_print(this, kstp, endofperiod) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object - integer(I4B), intent(in) :: kstp !< current time step - logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period + class(PrintSaveManagerType) :: this !< psm object + integer(I4B), intent(in) :: kstp !< current time step + logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period ! -- local integer(I4B) :: i, n ! kstp_to_print = .false. - if(this%print_all) kstp_to_print = .true. - if(kstp == 1 .and. this%print_first) kstp_to_print = .true. - if(endofperiod .and. this%print_last) kstp_to_print = .true. - if(this%ifreq_print > 0) then - if(mod(kstp, this%ifreq_print) == 0) kstp_to_print = .true. - endif + if (this%print_all) kstp_to_print = .true. + if (kstp == 1 .and. this%print_first) kstp_to_print = .true. + if (endofperiod .and. this%print_last) kstp_to_print = .true. + if (this%ifreq_print > 0) then + if (mod(kstp, this%ifreq_print) == 0) kstp_to_print = .true. + end if n = size(this%kstp_list_print) - if(n > 0) then + if (n > 0) then do i = 1, n - if(kstp == this%kstp_list_print(i)) then + if (kstp == this%kstp_list_print(i)) then kstp_to_print = .true. exit - endif - enddo - endif + end if + end do + end if ! ! -- Return return end function kstp_to_print - + !> @ brief Determine if it is time to save the data !! - !! Determine if data should be saved based on kstp and endofperiod + !! Determine if data should be saved based on kstp and endofperiod !! !< logical function kstp_to_save(this, kstp, endofperiod) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object - integer(I4B), intent(in) :: kstp !< current time step - logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period + class(PrintSaveManagerType) :: this !< psm object + integer(I4B), intent(in) :: kstp !< current time step + logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period ! -- local integer(I4B) :: i, n ! kstp_to_save = .false. - if(this%save_all) kstp_to_save = .true. - if(kstp == 1 .and. this%save_first) kstp_to_save = .true. - if(endofperiod .and. this%save_last) kstp_to_save = .true. - if(this%ifreq_save > 0) then - if(mod(kstp, this%ifreq_save) == 0) kstp_to_save = .true. - endif + if (this%save_all) kstp_to_save = .true. + if (kstp == 1 .and. this%save_first) kstp_to_save = .true. + if (endofperiod .and. this%save_last) kstp_to_save = .true. + if (this%ifreq_save > 0) then + if (mod(kstp, this%ifreq_save) == 0) kstp_to_save = .true. + end if n = size(this%kstp_list_save) - if(n > 0) then + if (n > 0) then do i = 1, n - if(kstp == this%kstp_list_save(i)) then + if (kstp == this%kstp_list_save(i)) then kstp_to_save = .true. exit - endif - enddo - endif + end if + end do + end if ! ! -- Return return end function kstp_to_save - -end module PrintSaveManagerModule \ No newline at end of file + +end module PrintSaveManagerModule diff --git a/src/Utilities/PackageBudget.f90 b/src/Utilities/PackageBudget.f90 index e1c37a63a57..93f1f5b2c6b 100644 --- a/src/Utilities/PackageBudget.f90 +++ b/src/Utilities/PackageBudget.f90 @@ -1,44 +1,44 @@ -!> @brief This module contains the PackageBudgetModule Module +!> @brief This module contains the PackageBudgetModule Module !! !! The PackageBudgetType object defined here provides flows to the GWT !! model. The PackageBudgetType can be filled with flows from a budget -!! object that was written from a previous GWF simulation, or its +!! object that was written from a previous GWF simulation, or its !! individual members can be pointed to flows that are being calculated !! by a GWF model that is running as part of this simulation. !< module PackageBudgetModule - + use KindModule use ConstantsModule, only: LENPACKAGENAME, LENAUXNAME, LENMEMPATH - use MemoryManagerModule, only: mem_allocate, mem_reassignptr, & + use MemoryManagerModule, only: mem_allocate, mem_reassignptr, & mem_reallocate, mem_deallocate implicit none - + private public :: PackageBudgetType - - !> @brief Derived type for storing flows + + !> @brief Derived type for storing flows !! !! This derived type stores flows and provides them through the FMI - !! package to other parts of GWT. + !! package to other parts of GWT. !! !< type :: PackageBudgetType - - character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored - character(len=LENPACKAGENAME), pointer :: name => null() !< name of the package - character(len=LENPACKAGENAME), pointer :: budtxt => null() !< type of flow (CHD, RCH, RCHA, ...) - character(len=LENAUXNAME), dimension(:), pointer, & - contiguous :: auxname => null() !< vector of auxname - integer(I4B), pointer :: naux => null() !< number of auxiliary variables - integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< vector of reduced node numbers - real(DP), dimension(:), pointer, contiguous :: flow => null() !< calculated flow - real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !< auxiliary variable array - + + character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored + character(len=LENPACKAGENAME), pointer :: name => null() !< name of the package + character(len=LENPACKAGENAME), pointer :: budtxt => null() !< type of flow (CHD, RCH, RCHA, ...) + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: auxname => null() !< vector of auxname + integer(I4B), pointer :: naux => null() !< number of auxiliary variables + integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< vector of reduced node numbers + real(DP), dimension(:), pointer, contiguous :: flow => null() !< calculated flow + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< auxiliary variable array + contains - + procedure :: initialize procedure :: set_name procedure :: set_auxname @@ -46,19 +46,19 @@ module PackageBudgetModule procedure :: copy_values procedure :: get_flow procedure :: da - - end type PackageBudgetType - - contains - + + end type PackageBudgetType + +contains + !> @ brief Initialize a PackageBudgetType object !! - !! Establish the memory path and allocate and initialize member variables. + !! Establish the memory path and allocate and initialize member variables. !! !< subroutine initialize(this, mempath) - class(PackageBudgetType) :: this !< PackageBudgetType object - character(len=*), intent(in) :: mempath !< memory path in memory manager + class(PackageBudgetType) :: this !< PackageBudgetType object + character(len=*), intent(in) :: mempath !< memory path in memory manager this%memoryPath = mempath ! ! -- allocate member variables in memory manager @@ -78,50 +78,51 @@ subroutine initialize(this, mempath) this%nbound = 0 return end subroutine initialize - + !> @ brief Set names for this PackageBudgetType object !! - !! Set the name of the package and the name of the of budget text + !! Set the name of the package and the name of the of budget text !! !< subroutine set_name(this, name, budtxt) - class(PackageBudgetType) :: this !< PackageBudgetType object - character(len=LENPACKAGENAME) :: name !< name of the package (WEL-1, DRN-4, etc.) - character(len=LENPACKAGENAME) :: budtxt !< name of budget term (CHD, RCH, EVT, DRN-TO-MVR, etc.) + class(PackageBudgetType) :: this !< PackageBudgetType object + character(len=LENPACKAGENAME) :: name !< name of the package (WEL-1, DRN-4, etc.) + character(len=LENPACKAGENAME) :: budtxt !< name of budget term (CHD, RCH, EVT, DRN-TO-MVR, etc.) this%name = name this%budtxt = budtxt return end subroutine set_name - + !> @ brief Set aux names for this PackageBudgetType object !! - !! Set the number of auxiliary variables and the names of the + !! Set the number of auxiliary variables and the names of the !! auxiliary variables !! !< subroutine set_auxname(this, naux, auxname) - class(PackageBudgetType) :: this !< PackageBudgetType object - integer(I4B), intent(in) :: naux !< number of auxiliary variables + class(PackageBudgetType) :: this !< PackageBudgetType object + integer(I4B), intent(in) :: naux !< number of auxiliary variables character(len=LENAUXNAME), contiguous, & - dimension(:), intent(in) :: auxname !< array of names for auxiliary variables + dimension(:), intent(in) :: auxname !< array of names for auxiliary variables this%naux = naux - call mem_reallocate(this%auxname, LENAUXNAME, naux, 'AUXNAME', this%memoryPath) + call mem_reallocate(this%auxname, LENAUXNAME, naux, 'AUXNAME', & + this%memoryPath) this%auxname(:) = auxname(:) return end subroutine set_auxname - + !> @ brief Point members of this class to data stored in GWF packages !! - !! The routine is called when a GWF model is being run concurrently with + !! The routine is called when a GWF model is being run concurrently with !! a GWT model. In this situation, the member variables NBOUND, NODELIST, !! FLOW, and AUXVAR are pointed into member variables of the individual !! GWF Package members stored in BndType. !! !< subroutine set_pointers(this, flowvarname, mem_path_target) - class(PackageBudgetType) :: this !< PackageBudgetType object - character(len=*), intent(in) :: flowvarname !< name of variable storing flow (SIMVALS, SIMTOMVR) - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + class(PackageBudgetType) :: this !< PackageBudgetType object + character(len=*), intent(in) :: flowvarname !< name of variable storing flow (SIMVALS, SIMTOMVR) + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! ! -- Reassign pointers to variables in the flow model call mem_reassignptr(this%nbound, 'NBOUND', this%memoryPath, & @@ -132,7 +133,7 @@ subroutine set_pointers(this, flowvarname, mem_path_target) flowvarname, mem_path_target) call mem_reassignptr(this%auxvar, 'AUXVAR', this%memoryPath, & 'AUXVAR', mem_path_target) - return + return end subroutine set_pointers !> @ brief Copy data read from a budget file into this object @@ -144,11 +145,11 @@ end subroutine set_pointers !! !< subroutine copy_values(this, nbound, nodelist, flow, auxvar) - class(PackageBudgetType) :: this !< PackageBudgetType object - integer(I4B), intent(in) :: nbound !< number of entries - integer(I4B), dimension(:), contiguous, intent(in) :: nodelist !< array of GWT node numbers - real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flow rates - real(DP), dimension(:,:), contiguous, intent(in) :: auxvar !< array of auxiliary variables + class(PackageBudgetType) :: this !< PackageBudgetType object + integer(I4B), intent(in) :: nbound !< number of entries + integer(I4B), dimension(:), contiguous, intent(in) :: nodelist !< array of GWT node numbers + real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flow rates + real(DP), dimension(:, :), contiguous, intent(in) :: auxvar !< array of auxiliary variables integer(I4B) :: i ! ! -- Assign variables @@ -159,8 +160,9 @@ subroutine copy_values(this, nbound, nodelist, flow, auxvar) if (size(this%nodelist) < nbound) then call mem_reallocate(this%nodelist, nbound, 'NODELIST', this%memoryPath) call mem_reallocate(this%flow, nbound, 'FLOW', this%memoryPath) - call mem_reallocate(this%auxvar, this%naux, nbound, 'AUXVAR', this%memoryPath) - endif + call mem_reallocate(this%auxvar, this%naux, nbound, 'AUXVAR', & + this%memoryPath) + end if ! ! -- Copy values into member variables do i = 1, nbound @@ -169,20 +171,20 @@ subroutine copy_values(this, nbound, nodelist, flow, auxvar) this%auxvar(:, i) = auxvar(:, i) end do end subroutine copy_values - + !> @ brief Get flow rate for specified entry !! !! Return the flow rate for the specified entry !! !< function get_flow(this, i) result(flow) - class(PackageBudgetType) :: this !< PackageBudgetType object - integer(I4B), intent(in) :: i !< entry number + class(PackageBudgetType) :: this !< PackageBudgetType object + integer(I4B), intent(in) :: i !< entry number real(DP) :: flow flow = this%flow(i) return end function get_flow - + !> @ brief Deallocate !! !! Free any memory associated with this object @@ -200,5 +202,5 @@ subroutine da(this) call mem_deallocate(this%auxvar, 'AUXVAR', this%memoryPath) return end subroutine da - -end module PackageBudgetModule \ No newline at end of file + +end module PackageBudgetModule diff --git a/src/Utilities/Sim.f90 b/src/Utilities/Sim.f90 index 7ee1ec9458a..50fdfe1340a 100644 --- a/src/Utilities/Sim.f90 +++ b/src/Utilities/Sim.f90 @@ -2,25 +2,25 @@ !! !! This module contains simulation methods for storing warning and error !! messages and notes. This module also has methods for counting warnings, -!! errors, and notes in addition to stopping the simulation. The module does -!! not have any dependencies on models, exchanges, or solutions in a +!! errors, and notes in addition to stopping the simulation. The module does +!! not have any dependencies on models, exchanges, or solutions in a !! simulation. !! !< module SimModule - - use KindModule, only: DP, I4B - use DefinedMacros, only: get_os - use ConstantsModule, only: MAXCHARLEN, LINELENGTH, & - DONE, & - IUSTART, IULAST, & - VSUMMARY, VALL, VDEBUG, & - OSWIN, OSUNDEF - use SimVariablesModule, only: istdout, iout, isim_level, ireturnerr, & - iforcestop, iunext, & - warnmsg + + use KindModule, only: DP, I4B + use DefinedMacros, only: get_os + use ConstantsModule, only: MAXCHARLEN, LINELENGTH, & + DONE, & + IUSTART, IULAST, & + VSUMMARY, VALL, VDEBUG, & + OSWIN, OSUNDEF + use SimVariablesModule, only: istdout, iout, isim_level, ireturnerr, & + iforcestop, iunext, & + warnmsg use GenericUtilitiesModule, only: sim_message, stop_with_error - use MessageModule, only: MessageType + use MessageModule, only: MessageType implicit none @@ -40,567 +40,567 @@ module SimModule public :: store_error_unit public :: store_error_filename public :: MaxErrors - + type(MessageType) :: sim_errors type(MessageType) :: sim_uniterrors type(MessageType) :: sim_warnings type(MessageType) :: sim_notes - contains +contains - !> @brief Return number of errors + !> @brief Return number of errors !! !! Function to return the number of errors messages that have been stored. !! !! @return ncount number of error messages stored !! - !< - function count_errors() result(ncount) - ! -- return variable - integer(I4B) :: ncount - ! - ! -- set ncount - ncount = sim_errors%count_message() - ! - ! -- return - return - end function count_errors + !< + function count_errors() result(ncount) + ! -- return variable + integer(I4B) :: ncount + ! + ! -- set ncount + ncount = sim_errors%count_message() + ! + ! -- return + return + end function count_errors - !> @brief Return number of warnings + !> @brief Return number of warnings !! !! Function to return the number of warning messages that have been stored. !! !! @return ncount number of warning messages stored !! - !< - function count_warnings() result(ncount) - ! -- return variable - integer(I4B) :: ncount - ! - ! -- set ncount - ncount = sim_warnings%count_message() - ! - ! -- return - return - end function count_warnings + !< + function count_warnings() result(ncount) + ! -- return variable + integer(I4B) :: ncount + ! + ! -- set ncount + ncount = sim_warnings%count_message() + ! + ! -- return + return + end function count_warnings - !> @brief Return number of notes + !> @brief Return number of notes !! !! Function to return the number of notes that have been stored. !! !! @return ncount number of notes stored !! - !< - function count_notes() result(ncount) - ! -- return variable - integer(I4B) :: ncount - ! - ! -- set ncount - ncount = sim_notes%count_message() - ! - ! -- return - return - end function count_notes + !< + function count_notes() result(ncount) + ! -- return variable + integer(I4B) :: ncount + ! + ! -- set ncount + ncount = sim_notes%count_message() + ! + ! -- return + return + end function count_notes - !> @brief Set the maximum number of errors stored + !> @brief Set the maximum number of errors stored !! !! Subroutine to set the maximum number of error messages that will be stored !! in a simulation. !! - !< - subroutine MaxErrors(imax) - ! -- dummy variables - integer(I4B), intent(in) :: imax !< maximum number of error messages that will be stored - ! - ! -- set the maximum number of error messages that will be saved - call sim_errors%set_max_message(imax) - ! - ! -- return - return - end subroutine MaxErrors + !< + subroutine MaxErrors(imax) + ! -- dummy variables + integer(I4B), intent(in) :: imax !< maximum number of error messages that will be stored + ! + ! -- set the maximum number of error messages that will be saved + call sim_errors%set_max_message(imax) + ! + ! -- return + return + end subroutine MaxErrors - !> @brief Store error message + !> @brief Store error message !! !! Subroutine to store a error message for printing at the end of !! the simulation. !! - !< - subroutine store_error(msg, terminate) - ! -- dummy variable - character(len=*), intent(in) :: msg !< error message - logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated - ! -- local variables - logical :: lterminate - ! - ! -- process optional variables - if (present(terminate)) then - lterminate = terminate - else - lterminate = .FALSE. - end if - ! - ! -- store error - call sim_errors%store_message(msg) - ! - ! -- terminate the simulation - if (lterminate) then - call ustop() - end if - ! - ! -- return - return - end subroutine store_error + !< + subroutine store_error(msg, terminate) + ! -- dummy variable + character(len=*), intent(in) :: msg !< error message + logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated + ! -- local variables + logical :: lterminate + ! + ! -- process optional variables + if (present(terminate)) then + lterminate = terminate + else + lterminate = .FALSE. + end if + ! + ! -- store error + call sim_errors%store_message(msg) + ! + ! -- terminate the simulation + if (lterminate) then + call ustop() + end if + ! + ! -- return + return + end subroutine store_error - !> @brief Get the file name + !> @brief Get the file name !! !! Subroutine to get the file name from the unit number for a open file. - !! If the INQUIRE function returns the full path (for example, the INTEL - !! compiler) then the returned file name (fname) is limited to the filename + !! If the INQUIRE function returns the full path (for example, the INTEL + !! compiler) then the returned file name (fname) is limited to the filename !! without the path. !! - !< - subroutine get_filename(iunit, fname) - ! -- dummy variables - integer(I4B), intent(in) :: iunit !< open file unit number - character(len=*), intent(inout) :: fname !< file name attached to the open file unit number - ! -- local variables - integer(I4B) :: ipos - integer(I4B) :: ios - integer(I4B) :: ilen - ! - ! -- get file name from unit number - inquire(unit=iunit, name=fname) - ! - ! -- determine the operating system - ios = get_os() - ! - ! -- extract filename from full path, if present - ! forward slash on linux, unix, and osx - if (ios /= OSWIN) then - ipos = index(fname, '/', back=.TRUE.) - end if - ! - ! -- check for backslash on windows or undefined os and - ! forward slashes were not found - if (ios == OSWIN .or. ios == OSUNDEF) then - if (ipos < 1) then - ipos = index(fname, '\', back=.TRUE.) - end if - end if - ! - ! -- exclude the path from the file name - if (ipos > 0) then - ilen = len_trim(fname) - write(fname, '(a)') fname(ipos+1:ilen) // ' ' + !< + subroutine get_filename(iunit, fname) + ! -- dummy variables + integer(I4B), intent(in) :: iunit !< open file unit number + character(len=*), intent(inout) :: fname !< file name attached to the open file unit number + ! -- local variables + integer(I4B) :: ipos + integer(I4B) :: ios + integer(I4B) :: ilen + ! + ! -- get file name from unit number + inquire (unit=iunit, name=fname) + ! + ! -- determine the operating system + ios = get_os() + ! + ! -- extract filename from full path, if present + ! forward slash on linux, unix, and osx + if (ios /= OSWIN) then + ipos = index(fname, '/', back=.TRUE.) + end if + ! + ! -- check for backslash on windows or undefined os and + ! forward slashes were not found + if (ios == OSWIN .or. ios == OSUNDEF) then + if (ipos < 1) then + ipos = index(fname, '\', back=.TRUE.) end if - ! - ! -- return - return - end subroutine get_filename + end if + ! + ! -- exclude the path from the file name + if (ipos > 0) then + ilen = len_trim(fname) + write (fname, '(a)') fname(ipos + 1:ilen)//' ' + end if + ! + ! -- return + return + end subroutine get_filename - !> @brief Store the file unit number + !> @brief Store the file unit number !! !! Subroutine to convert the unit number for a open file to a file name !! and indicate that there is an error reading from the file. By default, !! the simulation is terminated when this subroutine is called. !! - !< - subroutine store_error_unit(iunit, terminate) - ! -- dummy variables - integer(I4B), intent(in) :: iunit !< open file unit number - logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated - ! -- local variables - logical :: lterminate - character(len=LINELENGTH) :: fname - character(len=LINELENGTH) :: errmsg - ! - ! -- process optional variables - if (present(terminate)) then - lterminate = terminate - else - lterminate = .TRUE. - end if - ! - ! -- store error unit - inquire(unit=iunit, name=fname) - write(errmsg,'(3a)') & - "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(fname)), "'" - call sim_uniterrors%store_message(errmsg) - ! - ! -- terminate the simulation - if (lterminate) then - call ustop() - end if - ! - ! -- return - return - end subroutine store_error_unit + !< + subroutine store_error_unit(iunit, terminate) + ! -- dummy variables + integer(I4B), intent(in) :: iunit !< open file unit number + logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated + ! -- local variables + logical :: lterminate + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: errmsg + ! + ! -- process optional variables + if (present(terminate)) then + lterminate = terminate + else + lterminate = .TRUE. + end if + ! + ! -- store error unit + inquire (unit=iunit, name=fname) + write (errmsg, '(3a)') & + "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(fname)), "'" + call sim_uniterrors%store_message(errmsg) + ! + ! -- terminate the simulation + if (lterminate) then + call ustop() + end if + ! + ! -- return + return + end subroutine store_error_unit - !> @brief Store the erroring file name + !> @brief Store the erroring file name !! !! Subroutine to store the file name issuing an error. By default, !! the simulation is terminated when this subroutine is called !! - !< - subroutine store_error_filename(filename, terminate) - ! -- dummy variables - character(len=*), intent(in) :: filename !< erroring file name - logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated - ! -- local variables - logical :: lterminate - character(len=LINELENGTH) :: errmsg - ! - ! -- process optional variables - if (present(terminate)) then - lterminate = terminate - else - lterminate = .TRUE. - end if - ! - ! -- store error unit - write(errmsg,'(3a)') & - "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(filename)), "'" - call sim_uniterrors%store_message(errmsg) - ! - ! -- terminate the simulation - if (lterminate) then - call ustop() - end if - ! - ! -- return - return - end subroutine store_error_filename + !< + subroutine store_error_filename(filename, terminate) + ! -- dummy variables + character(len=*), intent(in) :: filename !< erroring file name + logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated + ! -- local variables + logical :: lterminate + character(len=LINELENGTH) :: errmsg + ! + ! -- process optional variables + if (present(terminate)) then + lterminate = terminate + else + lterminate = .TRUE. + end if + ! + ! -- store error unit + write (errmsg, '(3a)') & + "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(filename)), "'" + call sim_uniterrors%store_message(errmsg) + ! + ! -- terminate the simulation + if (lterminate) then + call ustop() + end if + ! + ! -- return + return + end subroutine store_error_filename - !> @brief Store warning message + !> @brief Store warning message !! !! Subroutine to store a warning message for printing at the end of !! the simulation. !! - !< - subroutine store_warning(msg, substring) - ! -- dummy variables - character(len=*), intent(in) :: msg !< warning message - character(len=*), intent(in), optional :: substring !< optional string that can be used - !! to prevent storing duplicate messages - ! - ! -- store warning - if (present(substring)) then - call sim_warnings%store_message(msg, substring) - else - call sim_warnings%store_message(msg) - end if - ! - ! -- return - return - end subroutine store_warning + !< + subroutine store_warning(msg, substring) + ! -- dummy variables + character(len=*), intent(in) :: msg !< warning message + character(len=*), intent(in), optional :: substring !< optional string that can be used + !! to prevent storing duplicate messages + ! + ! -- store warning + if (present(substring)) then + call sim_warnings%store_message(msg, substring) + else + call sim_warnings%store_message(msg) + end if + ! + ! -- return + return + end subroutine store_warning - !> @brief Store deprecation warning message + !> @brief Store deprecation warning message !! - !! Subroutine to store a warning message for deprecated variables + !! Subroutine to store a warning message for deprecated variables !! and printing at the end of simulation. !! - !< - subroutine deprecation_warning(cblock, cvar, cver, endmsg, iunit) - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy variables - character(len=*), intent(in) :: cblock !< block name - character(len=*), intent(in) :: cvar !< variable name - character(len=*), intent(in) :: cver !< version when variable was deprecated - character(len=*), intent(in), optional :: endmsg !< optional user defined message to append - !! at the end of the deprecation warning - integer(I4B), intent(in), optional :: iunit !< optional input file unit number with - !! the deprecated variable - ! -- local variables - character(len=MAXCHARLEN) :: message - character(len=LINELENGTH) :: fname - ! - ! -- build message - write(message,'(a)') & - trim(cblock) // " BLOCK VARIABLE '" // trim(cvar) // "'" - if (present(iunit)) then - call get_filename(iunit, fname) - write(message,'(a,1x,3a)') & - trim(message), "IN FILE '", trim(fname), "'" - end if - write(message,'(a)') & - trim(message) // ' WAS DEPRECATED IN VERSION ' // trim(cver) // '.' - if (present(endmsg)) then - write(message,'(a,1x,2a)') trim(message), trim(endmsg), '.' - end if - ! - ! -- store warning - call sim_warnings%store_message(message) - ! - ! -- return - return - end subroutine deprecation_warning + !< + subroutine deprecation_warning(cblock, cvar, cver, endmsg, iunit) + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy variables + character(len=*), intent(in) :: cblock !< block name + character(len=*), intent(in) :: cvar !< variable name + character(len=*), intent(in) :: cver !< version when variable was deprecated + character(len=*), intent(in), optional :: endmsg !< optional user defined message to append + !! at the end of the deprecation warning + integer(I4B), intent(in), optional :: iunit !< optional input file unit number with + !! the deprecated variable + ! -- local variables + character(len=MAXCHARLEN) :: message + character(len=LINELENGTH) :: fname + ! + ! -- build message + write (message, '(a)') & + trim(cblock)//" BLOCK VARIABLE '"//trim(cvar)//"'" + if (present(iunit)) then + call get_filename(iunit, fname) + write (message, '(a,1x,3a)') & + trim(message), "IN FILE '", trim(fname), "'" + end if + write (message, '(a)') & + trim(message)//' WAS DEPRECATED IN VERSION '//trim(cver)//'.' + if (present(endmsg)) then + write (message, '(a,1x,2a)') trim(message), trim(endmsg), '.' + end if + ! + ! -- store warning + call sim_warnings%store_message(message) + ! + ! -- return + return + end subroutine deprecation_warning - !> @brief Store note + !> @brief Store note !! !! Subroutine to store a note for printing at the end of the simulation. !! - !< - subroutine store_note(note) - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy variables - character(len=*), intent(in) :: note !< note - ! - ! -- store note - call sim_notes%store_message(note) - ! - ! -- return - return - end subroutine store_note + !< + subroutine store_note(note) + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy variables + character(len=*), intent(in) :: note !< note + ! + ! -- store note + call sim_notes%store_message(note) + ! + ! -- return + return + end subroutine store_note - !> @brief Stop the simulation. + !> @brief Stop the simulation. !! - !! Subroutine to stop the simulations with option to print message + !! Subroutine to stop the simulations with option to print message !! before stopping with the active error code. !! - !< - subroutine ustop(stopmess, ioutlocal) - ! -- dummy variables - character, optional, intent(in) :: stopmess*(*) !< optional message to print before - !! stopping the simulation - integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to - !! final message to - ! - ! -- print the final message - call print_final_message(stopmess, ioutlocal) - ! - ! -- return appropriate error codes when terminating the program - call stop_with_error(ireturnerr) - - end subroutine ustop + !< + subroutine ustop(stopmess, ioutlocal) + ! -- dummy variables + character, optional, intent(in) :: stopmess * (*) !< optional message to print before + !! stopping the simulation + integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to + !! final message to + ! + ! -- print the final message + call print_final_message(stopmess, ioutlocal) + ! + ! -- return appropriate error codes when terminating the program + call stop_with_error(ireturnerr) - !> @brief Print the final messages + end subroutine ustop + + !> @brief Print the final messages !! - !! Subroutine to print the notes, warnings, errors and the final message (if passed). + !! Subroutine to print the notes, warnings, errors and the final message (if passed). !! The subroutine also closes all open files. !! - !< - subroutine print_final_message(stopmess, ioutlocal) - ! -- dummy variables - character, optional, intent(in) :: stopmess*(*) !< optional message to print before - !! stopping the simulation - integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to - !! final message to - ! -- local variables - character(len=*), parameter :: fmt = '(1x,a)' - character(len=*), parameter :: msg = 'Stopping due to error(s)' - ! - ! -- print the accumulated messages - call sim_notes%print_message('NOTES:', 'note(s)', & - iunit=iout, level=VALL) - call sim_warnings%print_message('WARNING REPORT:', 'warning(s)', & - iunit=iout, level=VALL) - call sim_errors%print_message('ERROR REPORT:', 'error(s)', iunit=iout) - call sim_uniterrors%print_message('UNIT ERROR REPORT:', & - 'file unit error(s)', iunit=iout) - ! - ! -- write a stop message, if one is passed - if (present(stopmess)) then - if (stopmess.ne.' ') then - call sim_message(stopmess, fmt=fmt, iunit=iout) - call sim_message(stopmess, fmt=fmt) - if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal /= iout) then - write(ioutlocal,fmt) trim(stopmess) - close (ioutlocal) - endif - endif - endif - endif - ! - ! -- determine if an error condition has occurred - if (sim_errors%count_message() > 0) then - ireturnerr = 2 + !< + subroutine print_final_message(stopmess, ioutlocal) + ! -- dummy variables + character, optional, intent(in) :: stopmess * (*) !< optional message to print before + !! stopping the simulation + integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to + !! final message to + ! -- local variables + character(len=*), parameter :: fmt = '(1x,a)' + character(len=*), parameter :: msg = 'Stopping due to error(s)' + ! + ! -- print the accumulated messages + call sim_notes%print_message('NOTES:', 'note(s)', & + iunit=iout, level=VALL) + call sim_warnings%print_message('WARNING REPORT:', 'warning(s)', & + iunit=iout, level=VALL) + call sim_errors%print_message('ERROR REPORT:', 'error(s)', iunit=iout) + call sim_uniterrors%print_message('UNIT ERROR REPORT:', & + 'file unit error(s)', iunit=iout) + ! + ! -- write a stop message, if one is passed + if (present(stopmess)) then + if (stopmess .ne. ' ') then + call sim_message(stopmess, fmt=fmt, iunit=iout) + call sim_message(stopmess, fmt=fmt) if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal /= iout) write(ioutlocal,fmt) msg - endif - endif - ! - ! -- close all open files - call sim_closefiles() - ! - ! -- return - return - end subroutine print_final_message + if (ioutlocal > 0 .and. ioutlocal /= iout) then + write (ioutlocal, fmt) trim(stopmess) + close (ioutlocal) + end if + end if + end if + end if + ! + ! -- determine if an error condition has occurred + if (sim_errors%count_message() > 0) then + ireturnerr = 2 + if (present(ioutlocal)) then + if (ioutlocal > 0 .and. ioutlocal /= iout) write (ioutlocal, fmt) msg + end if + end if + ! + ! -- close all open files + call sim_closefiles() + ! + ! -- return + return + end subroutine print_final_message - !> @brief Reset the simulation convergence flag + !> @brief Reset the simulation convergence flag !! !! Subroutine to reset the simulation convergence flag. !! - !< - subroutine converge_reset() - ! -- modules - use SimVariablesModule, only: isimcnvg - ! - ! -- reset simulation convergence flag - isimcnvg = 1 - ! - ! -- return - return - end subroutine converge_reset + !< + subroutine converge_reset() + ! -- modules + use SimVariablesModule, only: isimcnvg + ! + ! -- reset simulation convergence flag + isimcnvg = 1 + ! + ! -- return + return + end subroutine converge_reset - !> @brief Simulation convergence check + !> @brief Simulation convergence check !! !! Subroutine to check simulation convergence. If the continue option is !! set the simulation convergence flag is set to True if the simulation !! did not actually converge for a time step and the non-convergence counter !! is incremented. !! - !< - subroutine converge_check(hasConverged) - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue - ! -- dummy variables - logical, intent(inout) :: hasConverged !< boolean indicting if the - !! simulation is considered converged - ! -- format - character(len=*), parameter :: fmtfail = & - "(1x, 'Simulation convergence failure.', & - &' Simulation will terminate after output and deallocation.')" - ! - ! -- Initialize hasConverged to True - hasConverged = .true. - ! - ! -- Count number of failures - if(isimcnvg == 0) then - numnoconverge = numnoconverge + 1 + !< + subroutine converge_check(hasConverged) + ! -- modules + use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue + ! -- dummy variables + logical, intent(inout) :: hasConverged !< boolean indicting if the + !! simulation is considered converged + ! -- format + character(len=*), parameter :: fmtfail = & + "(1x, 'Simulation convergence failure.', & + &' Simulation will terminate after output and deallocation.')" + ! + ! -- Initialize hasConverged to True + hasConverged = .true. + ! + ! -- Count number of failures + if (isimcnvg == 0) then + numnoconverge = numnoconverge + 1 + end if + ! + ! -- Continue if 'CONTINUE' specified in simulation control file + if (isimcontinue == 1) then + if (isimcnvg == 0) then + isimcnvg = 1 end if - ! - ! -- Continue if 'CONTINUE' specified in simulation control file - if(isimcontinue == 1) then - if(isimcnvg == 0) then - isimcnvg = 1 - endif - endif - ! - ! -- save simulation failure message - if(isimcnvg == 0) then - call sim_message('', fmt=fmtfail, iunit=iout) - hasConverged = .false. - endif - ! - ! -- return - return - end subroutine converge_check + end if + ! + ! -- save simulation failure message + if (isimcnvg == 0) then + call sim_message('', fmt=fmtfail, iunit=iout) + hasConverged = .false. + end if + ! + ! -- return + return + end subroutine converge_check - !> @brief Print the header and initializes messaging - !! - !! Subroutine that prints the initial message and initializes the notes, - !! warning messages, unit errors, and error messages. - !! - !< - subroutine initial_message() - ! -- modules - use VersionModule, only: write_listfile_header - ! - ! -- initialize message lists - call sim_errors%init_message() - call sim_uniterrors%init_message() - call sim_warnings%init_message() - call sim_notes%init_message() - ! - ! -- Write banner to screen (unit stdout) - call write_listfile_header(istdout, write_kind_info=.false., & - write_sys_command=.false.) - ! - end subroutine initial_message + !> @brief Print the header and initializes messaging + !! + !! Subroutine that prints the initial message and initializes the notes, + !! warning messages, unit errors, and error messages. + !! + !< + subroutine initial_message() + ! -- modules + use VersionModule, only: write_listfile_header + ! + ! -- initialize message lists + call sim_errors%init_message() + call sim_uniterrors%init_message() + call sim_warnings%init_message() + call sim_notes%init_message() + ! + ! -- Write banner to screen (unit stdout) + call write_listfile_header(istdout, write_kind_info=.false., & + write_sys_command=.false.) + ! + end subroutine initial_message - !> @brief Create final message - !! - !! Subroutine that creates the appropriate final message and - !! terminates the program with an error message, if necessary. - !! - !< - subroutine final_message() - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr, & - isimcontinue - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" - ! - ! -- Write message if nonconvergence occured in at least one timestep - if(numnoconverge > 0) then - write(warnmsg, fmtnocnvg) numnoconverge - if (isimcontinue == 0) then - call sim_errors%store_message(warnmsg) - else - call sim_warnings%store_message(warnmsg) - end if - endif - ! - ! -- write final message - if(isimcnvg == 0) then - call print_final_message('Premature termination of simulation.', iout) + !> @brief Create final message + !! + !! Subroutine that creates the appropriate final message and + !! terminates the program with an error message, if necessary. + !! + !< + subroutine final_message() + ! -- modules + use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr, & + isimcontinue + ! -- formats + character(len=*), parameter :: fmtnocnvg = & + &"(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" + ! + ! -- Write message if nonconvergence occured in at least one timestep + if (numnoconverge > 0) then + write (warnmsg, fmtnocnvg) numnoconverge + if (isimcontinue == 0) then + call sim_errors%store_message(warnmsg) else - call print_final_message('Normal termination of simulation.', iout) - endif - ! - ! -- If the simulation did not converge and the continue - ! option was not set, then set the return code to 1. The - ! purpose of setting the returncode this way is that the - ! program will terminate without a stop code if the simulation - ! reached the end and the continue flag was set, even if the - ! the simulation did not converge. - if (isimcnvg == 0 .and. isimcontinue == 0) then - ireturnerr = 1 + call sim_warnings%store_message(warnmsg) end if - ! - ! -- destroy messages - call sim_errors%deallocate_message() - call sim_uniterrors%deallocate_message() - call sim_warnings%deallocate_message() - call sim_notes%deallocate_message() - ! - ! -- return or halt - if (iforcestop == 1) then - call stop_with_error(ireturnerr) + end if + ! + ! -- write final message + if (isimcnvg == 0) then + call print_final_message('Premature termination of simulation.', iout) + else + call print_final_message('Normal termination of simulation.', iout) + end if + ! + ! -- If the simulation did not converge and the continue + ! option was not set, then set the return code to 1. The + ! purpose of setting the returncode this way is that the + ! program will terminate without a stop code if the simulation + ! reached the end and the continue flag was set, even if the + ! the simulation did not converge. + if (isimcnvg == 0 .and. isimcontinue == 0) then + ireturnerr = 1 + end if + ! + ! -- destroy messages + call sim_errors%deallocate_message() + call sim_uniterrors%deallocate_message() + call sim_warnings%deallocate_message() + call sim_notes%deallocate_message() + ! + ! -- return or halt + if (iforcestop == 1) then + call stop_with_error(ireturnerr) + end if + + end subroutine final_message + + !> @brief Close all open files + !! + !! Subroutine that closes all open files at the end of the simulation. + !! + !< + subroutine sim_closefiles() + ! -- modules + ! -- dummy + ! -- local variables + integer(I4B) :: i + logical :: opened + character(len=7) :: output_file + ! + ! -- close all open file units + do i = iustart, iunext - 1 + ! + ! -- determine if file unit i is open + inquire (unit=i, opened=opened) + ! + ! -- skip file units that are no longer open + if (.not. opened) then + cycle end if - - end subroutine final_message - - !> @brief Close all open files - !! - !! Subroutine that closes all open files at the end of the simulation. - !! - !< - subroutine sim_closefiles() - ! -- modules - ! -- dummy - ! -- local variables - integer(I4B) :: i - logical :: opened - character(len=7) :: output_file ! - ! -- close all open file units - do i = iustart, iunext - 1 - ! - ! -- determine if file unit i is open - inquire(unit=i, opened=opened) - ! - ! -- skip file units that are no longer open - if(.not. opened) then - cycle - end if - ! - ! -- flush the file if it can be written to - inquire(unit=i, write=output_file) - if (trim(adjustl(output_file)) == 'YES') then - flush(i) - end if - ! - ! -- close file unit i - close(i) - end do + ! -- flush the file if it can be written to + inquire (unit=i, write=output_file) + if (trim(adjustl(output_file)) == 'YES') then + flush (i) + end if ! - ! -- return - return - end subroutine sim_closefiles - + ! -- close file unit i + close (i) + end do + ! + ! -- return + return + end subroutine sim_closefiles + end module SimModule diff --git a/src/Utilities/SimVariables.f90 b/src/Utilities/SimVariables.f90 index 82b4f55a8bc..a86853f27c5 100644 --- a/src/Utilities/SimVariables.f90 +++ b/src/Utilities/SimVariables.f90 @@ -11,22 +11,22 @@ module SimVariablesModule use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, MAXCHARLEN, IUSTART, VALL, MNORMAL public - character(len=LINELENGTH) :: simfile = 'mfsim.nam' !< simulation name file - character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' !< simulation listing file name - character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' !< name of standard out file if screen output is piped to a file - character(len=MAXCHARLEN) :: errmsg !< error message string - character(len=MAXCHARLEN) :: warnmsg !< warning message string - integer(I4B) :: istdout = output_unit !< unit number for stdout - integer(I4B) :: isim_level = VALL !< simulation output level - integer(I4B) :: isim_mode = MNORMAL !< simulation mode - integer(I4B) :: iout !< file unit number for simulation output - integer(I4B) :: isimcnvg !< simulation convergence flag (1) if all objects have converged, (0) otherwise - integer(I4B) :: isimcontinue = 0 !< simulation continue flag (1) to continue if isimcnvg = 0, (0) to terminate - integer(I4B) :: isimcheck = 1 !< simulation input check flag (1) to check input, (0) to ignore checks - integer(I4B) :: numnoconverge = 0 !< number of times the simulation did not converge - integer(I4B) :: ireturnerr = 0 !< return code for program (0) successful, (1) non-convergence, (2) error - integer(I4B) :: iforcestop = 1 !< forced stop flag (1) forces a call to ustop(..) when the simulation has ended, (0) doesn't - integer(I4B) :: iunext = IUSTART !< next file unit number to assign - integer(I4B) :: lastStepFailed = 0 !< flag indicating if the last step failed (1) if last step failed; (0) otherwise (set in converge_check) - integer(I4B) :: iFailedStepRetry = 0 !< current retry for this time step + character(len=LINELENGTH) :: simfile = 'mfsim.nam' !< simulation name file + character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' !< simulation listing file name + character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' !< name of standard out file if screen output is piped to a file + character(len=MAXCHARLEN) :: errmsg !< error message string + character(len=MAXCHARLEN) :: warnmsg !< warning message string + integer(I4B) :: istdout = output_unit !< unit number for stdout + integer(I4B) :: isim_level = VALL !< simulation output level + integer(I4B) :: isim_mode = MNORMAL !< simulation mode + integer(I4B) :: iout !< file unit number for simulation output + integer(I4B) :: isimcnvg !< simulation convergence flag (1) if all objects have converged, (0) otherwise + integer(I4B) :: isimcontinue = 0 !< simulation continue flag (1) to continue if isimcnvg = 0, (0) to terminate + integer(I4B) :: isimcheck = 1 !< simulation input check flag (1) to check input, (0) to ignore checks + integer(I4B) :: numnoconverge = 0 !< number of times the simulation did not converge + integer(I4B) :: ireturnerr = 0 !< return code for program (0) successful, (1) non-convergence, (2) error + integer(I4B) :: iforcestop = 1 !< forced stop flag (1) forces a call to ustop(..) when the simulation has ended, (0) doesn't + integer(I4B) :: iunext = IUSTART !< next file unit number to assign + integer(I4B) :: lastStepFailed = 0 !< flag indicating if the last step failed (1) if last step failed; (0) otherwise (set in converge_check) + integer(I4B) :: iFailedStepRetry = 0 !< current retry for this time step end module SimVariablesModule diff --git a/src/Utilities/SmoothingFunctions.f90 b/src/Utilities/SmoothingFunctions.f90 index 12ae5ad60f4..c821e14c67d 100644 --- a/src/Utilities/SmoothingFunctions.f90 +++ b/src/Utilities/SmoothingFunctions.f90 @@ -1,17 +1,17 @@ module SmoothingModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, & - & DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM8, DEM14 + use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, & + DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM8, DEM14 implicit none - - contains - - subroutine sSCurve(x,range,dydx,y) + +contains + + subroutine sSCurve(x, range, dydx, y) ! ****************************************************************************** ! COMPUTES THE S CURVE FOR SMOOTH DERIVATIVES BETWEEN X=0 AND X=1 ! FROM mfusg smooth SUBROUTINE in gwf2wel7u1.f ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(in) :: x @@ -25,28 +25,28 @@ subroutine sSCurve(x,range,dydx,y) ! code ! s = range - if ( s < DPREC ) s = DPREC + if (s < DPREC) s = DPREC xs = x / s if (xs < DZERO) xs = DZERO if (xs <= DZERO) then y = DZERO dydx = DZERO - elseif(xs < DONE)then + elseif (xs < DONE) then y = -DTWO * xs**DTHREE + DTHREE * xs**DTWO dydx = -DSIX * xs**DTWO + DSIX * xs else y = DONE dydx = DZERO - endif + end if return end subroutine sSCurve - - subroutine sCubicLinear(x,range,dydx,y) + + subroutine sCubicLinear(x, range, dydx, y) ! ****************************************************************************** ! COMPUTES THE S CURVE WHERE DY/DX = 0 at X=0; AND DY/DX = 1 AT X=1. ! Smooths from zero to a slope of 1. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(in) :: x @@ -60,27 +60,27 @@ subroutine sCubicLinear(x,range,dydx,y) ! code ! s = range - if ( s < DPREC ) s = DPREC + if (s < DPREC) s = DPREC xs = x / s if (xs < DZERO) xs = DZERO if (xs <= DZERO) then y = DZERO dydx = DZERO - elseif(xs < DONE)then + elseif (xs < DONE) then y = -DONE * xs**DTHREE + DTWO * xs**DTWO dydx = -DTHREE * xs**DTWO + DFOUR * xs else y = DONE dydx = DZERO - endif + end if return end subroutine sCubicLinear - subroutine sCubic(x,range,dydx,y) + subroutine sCubic(x, range, dydx, y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; cubic function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(inout) :: x @@ -95,31 +95,31 @@ subroutine sCubic(x,range,dydx,y) ! dydx = DZERO y = DZERO - if ( range < DPREC ) range = DPREC - if ( x < DPREC ) x = DPREC + if (range < DPREC) range = DPREC + if (x < DPREC) x = DPREC s = range - aa = -DSIX/(s**DTHREE) - bb = -DSIX/(s**DTWO) + aa = -DSIX / (s**DTHREE) + bb = -DSIX / (s**DTWO) cof1 = x**DTWO - cof2 = -(DTWO*x)/(s**DTHREE) - cof3 = DTHREE/(s**DTWO) + cof2 = -(DTWO * x) / (s**DTHREE) + cof3 = DTHREE / (s**DTWO) y = cof1 * (cof2 + cof3) - dydx = (aa*x**DTWO - bb*x) - if ( x <= DZERO ) then + dydx = (aa * x**DTWO - bb * x) + if (x <= DZERO) then y = DZERO dydx = DZERO - else if ( (x - s) > -DPREC ) then + else if ((x - s) > -DPREC) then y = DONE dydx = DZERO end if return end subroutine sCubic - - subroutine sLinear(x,range,dydx,y) + + subroutine sLinear(x, range, dydx, y) ! ****************************************************************************** ! Linear smoothing function returns value between 0-1 ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(inout) :: x @@ -133,23 +133,23 @@ subroutine sLinear(x,range,dydx,y) ! dydx = DZERO y = DZERO - if ( range < DPREC ) range = DPREC - if ( x < DPREC ) x = DPREC + if (range < DPREC) range = DPREC + if (x < DPREC) x = DPREC s = range - y = DONE - (s - x)/s - dydx = DONE/s - if ( y > DONE ) then + y = DONE - (s - x) / s + dydx = DONE / s + if (y > DONE) then y = DONE dydx = DZERO end if return end subroutine sLinear - - subroutine sQuadratic(x,range,dydx,y) + + subroutine sQuadratic(x, range, dydx, y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; quadratic function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(inout) :: x @@ -163,12 +163,12 @@ subroutine sQuadratic(x,range,dydx,y) ! dydx = DZERO y = DZERO - if ( range < DPREC ) range = DPREC - if ( x < DPREC ) x = DPREC + if (range < DPREC) range = DPREC + if (x < DPREC) x = DPREC s = range y = (x**DTWO) / (s**DTWO) - dydx = DTWO*x/(s**DTWO) - if ( y > DONE ) then + dydx = DTWO * x / (s**DTWO) + if (y > DONE) then y = DONE dydx = DZERO end if @@ -179,7 +179,7 @@ subroutine sChSmooth(d, smooth, dwdh) ! ****************************************************************************** ! Function to smooth channel variables during channel drying ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(in) :: d @@ -196,38 +196,38 @@ subroutine sChSmooth(d, smooth, dwdh) real(DP) :: y ! ------------------------------------------------------------------------------ ! code -! +! smooth = DZERO s = DEM5 x = d diff = x - s - if ( diff > DZERO ) then + if (diff > DZERO) then smooth = DONE dwdh = DZERO else aa = -DONE / (s**DTWO) ad = -DTWO / (s**DTWO) b = DTWO / s - y = aa * x**DTWO + b*x - dwdh = (ad*x + b) - if ( x <= DZERO ) then + y = aa * x**DTWO + b * x + dwdh = (ad * x + b) + if (x <= DZERO) then y = DZERO dwdh = DZERO - else if ( diff > -DEM14 ) then + else if (diff > -DEM14) then y = DONE dwdh = DZERO end if smooth = y end if return -end subroutine sChSmooth - + end subroutine sChSmooth + function sLinearSaturation(top, bot, x) result(y) ! ****************************************************************************** ! Linear smoothing function returns value between 0-1; ! Linear saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -252,13 +252,12 @@ function sLinearSaturation(top, bot, x) result(y) return end function sLinearSaturation - function sCubicSaturation(top, bot, x, eps) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Quadratic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -292,24 +291,23 @@ function sCubicSaturation(top, bot, x, eps) result(y) y = DZERO else if (w < s) then y = -cof1 * (w**DTHREE) + cof2 * (w**DTWO) - else if (w < (b-s)) then + else if (w < (b - s)) then y = w / b else if (w < b) then y = DONE + cof1 * ((b - w)**DTHREE) - cof2 * ((b - w)**DTWO) else y = DONE end if - + return end function sCubicSaturation - function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Quadratic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -349,14 +347,14 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) else br = (x - bot) / b end if - av = DONE / (DONE - teps) + av = DONE / (DONE - teps) bri = DONE - br if (br < tbmin) then br = tbmin end if if (br < teps) then - y = av * DHALF * (br*br) / teps - elseif (br < (DONE-teps)) then + y = av * DHALF * (br * br) / teps + elseif (br < (DONE - teps)) then y = av * br + DHALF * (DONE - av) elseif (br < DONE) then y = DONE - ((av * DHALF * (bri * bri)) / teps) @@ -370,16 +368,16 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) y = DONE end if end if - + return end function sQuadraticSaturation - + function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! van Genuchten saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -412,14 +410,13 @@ function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y) return end function svanGenuchtenSaturation - - + function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) ! ****************************************************************************** ! Derivative of nonlinear smoothing function returns value between 0-1; ! Derivative of the quadratic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -458,14 +455,14 @@ function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) else br = (x - bot) / b end if - av = DONE / (DONE - teps) + av = DONE / (DONE - teps) bri = DONE - br if (br < tbmin) then br = tbmin end if if (br < teps) then y = av * br / teps - elseif (br < (DONE-teps)) then + elseif (br < (DONE - teps)) then y = av elseif (br < DONE) then y = av * bri / teps @@ -473,18 +470,16 @@ function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) y = DZERO end if y = y / b - + return end function sQuadraticSaturationDerivative - - function sQSaturation(top, bot, x, c1, c2) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Cubic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -531,7 +526,7 @@ function sQSaturation(top, bot, x, c1, c2) result(y) ! -- calculate fraction if (s < DZERO) then y = DZERO - else if(s < DONE) then + else if (s < DONE) then y = cof1 * w**DTHREE + cof2 * w**DTWO else y = DONE @@ -540,13 +535,13 @@ function sQSaturation(top, bot, x, c1, c2) result(y) ! -- return return end function sQSaturation - + function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Cubic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -569,7 +564,7 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! ! -- process optional variables if (present(c1)) then - cof1 = c1 + cof1 = c1 else cof1 = -DTWO end if @@ -586,7 +581,7 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) b = top - bot s = w / b ! - ! -- multiply cof1 and cof2 by 3 and 2, respectively, and then + ! -- multiply cof1 and cof2 by 3 and 2, respectively, and then ! divide by range to the power 3 and 2, respectively cof1 = cof1 * DTHREE / b**DTHREE cof2 = cof2 * DTWO / b**DTWO @@ -594,7 +589,7 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! -- calculate derivative of fraction with respect to x if (s < DZERO) then y = DZERO - else if(s < DONE) then + else if (s < DONE) then y = cof1 * w**DTWO + cof2 * w else y = DZERO @@ -603,14 +598,14 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! -- return return end function sQSaturationDerivative - + function sSlope(x, xi, yi, sm, sp, ta) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns a smoothed value of y that has the value ! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for ! x-values greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -654,15 +649,15 @@ function sSlope(x, xi, yi, sm, sp, ta) result(y) ! ! -- return return - end function sSlope - + end function sSlope + function sSlopeDerivative(x, xi, sm, sp, ta) result(y) ! ****************************************************************************** -! Derivative of nonlinear smoothing function that has the value yi at xi and -! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values +! Derivative of nonlinear smoothing function that has the value yi at xi and +! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values ! greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -697,20 +692,20 @@ function sSlopeDerivative(x, xi, sm, sp, ta) result(y) rho = dx / mu ! ! -- calculate derivative from individual contributions - y = DHALF * (sm + sp) - DHALF * rho * (sm - sp) + y = DHALF * (sm + sp) - DHALF * rho * (sm - sp) ! ! -- return return - end function sSlopeDerivative - + end function sSlopeDerivative + function sQuadratic0sp(x, xi, tomega) result(y) ! ****************************************************************************** -! Nonlinear smoothing function returns a smoothed value of y that uses a +! Nonlinear smoothing function returns a smoothed value of y that uses a ! quadratic to smooth x over range of xi - epsilon to xi + epsilon. ! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. ! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -749,16 +744,16 @@ function sQuadratic0sp(x, xi, tomega) result(y) ! ! -- return return - end function sQuadratic0sp - + end function sQuadratic0sp + function sQuadratic0spDerivative(x, xi, tomega) result(y) ! ****************************************************************************** -! Derivative of nonlinear smoothing function returns a smoothed value of y +! Derivative of nonlinear smoothing function returns a smoothed value of y ! that uses a quadratic to smooth x over range of xi - epsilon to xi + epsilon. ! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. ! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -797,15 +792,15 @@ function sQuadratic0spDerivative(x, xi, tomega) result(y) ! ! -- return return - end function sQuadratic0spDerivative - + end function sQuadratic0spDerivative + function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y) ! ****************************************************************************** ! Quadratic smoothing function returns a smoothed value of y that has the value ! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for ! x-values greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -852,16 +847,15 @@ function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y) ! ! -- return return - end function sQuadraticSlope - - + end function sQuadraticSlope + function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y) ! ****************************************************************************** -! Derivative of quadratic smoothing function returns a smoothed value of y -! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and +! Derivative of quadratic smoothing function returns a smoothed value of y +! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and ! yi + (sp * dx) for x-values greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -904,6 +898,6 @@ function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y) ! ! -- return return - end function sQuadraticSlopeDerivative - + end function sQuadraticSlopeDerivative + end module SmoothingModule diff --git a/src/Utilities/Sparse.f90 b/src/Utilities/Sparse.f90 index c3037070445..af01ef34d9a 100644 --- a/src/Utilities/Sparse.f90 +++ b/src/Utilities/Sparse.f90 @@ -3,278 +3,278 @@ module SparseModule !of a matrix. Module uses FORTRAN 2003 extensions to manage !the data structures in an object oriented fashion. - use KindModule, only: DP, I4B - implicit none - - type rowtype - integer(I4B) :: nnz ! number of nonzero entries in the row - integer(I4B), allocatable, dimension(:) :: icolarray ! array of column numbers - end type rowtype + use KindModule, only: DP, I4B + implicit none - type, public :: sparsematrix - integer(I4B) :: nrow ! number of rows in the matrix - integer(I4B) :: ncol ! number of columns in the matrix - integer(I4B) :: nnz ! number of nonzero matrix entries - type(rowtype), allocatable, dimension(:) :: row ! one rowtype for each matrix row - contains - generic :: init => initialize, initializefixed - procedure :: addconnection - procedure :: filliaja - procedure :: sort - procedure :: destroy + type rowtype + integer(I4B) :: nnz ! number of nonzero entries in the row + integer(I4B), allocatable, dimension(:) :: icolarray ! array of column numbers + end type rowtype - procedure, private :: initializefixed - procedure, private :: initialize - end type sparsematrix - - contains + type, public :: sparsematrix + integer(I4B) :: nrow ! number of rows in the matrix + integer(I4B) :: ncol ! number of columns in the matrix + integer(I4B) :: nnz ! number of nonzero matrix entries + type(rowtype), allocatable, dimension(:) :: row ! one rowtype for each matrix row + contains + generic :: init => initialize, initializefixed + procedure :: addconnection + procedure :: filliaja + procedure :: sort + procedure :: destroy - subroutine destroy(this) - class(sparsematrix), intent(inout) :: this - deallocate(this%row) - end subroutine destroy + procedure, private :: initializefixed + procedure, private :: initialize + end type sparsematrix - subroutine initialize(this,nrow,ncol,rowmaxnnz) - !initial the sparse matrix. This subroutine - !acts a method for a sparse matrix by initializing - !the row data. It presently requires one maximum - !value for all rows, however, this can be changed - !to a vector of maximum values with one value for - !each row. - ! -- dummy - class(sparsematrix), intent(inout) :: this - integer(I4B),intent(in) :: nrow,ncol - integer(I4B),intent(in),dimension(nrow) :: rowmaxnnz - ! -- local - integer(I4B) :: i - ! -- code - this%nrow = nrow - this%ncol = ncol - this%nnz = 0 - allocate(this%row(nrow)) - do i = 1, nrow - allocate(this%row(i)%icolarray(rowmaxnnz(i))) - this%row(i)%icolarray=0 - this%row(i)%nnz=0 - end do - ! - ! -- return - return - end subroutine initialize +contains - ! overload - subroutine initializefixed(this,nrow,ncol,maxnnz) - implicit none - class(sparsematrix), intent(inout) :: this - integer(I4B),intent(in) :: nrow,ncol - integer(I4B),intent(in) :: maxnnz - ! local - integer(I4B), dimension(:), allocatable :: rowmaxnnz - integer(I4B) :: i + subroutine destroy(this) + class(sparsematrix), intent(inout) :: this + deallocate (this%row) + end subroutine destroy - allocate(rowmaxnnz(nrow)) + subroutine initialize(this, nrow, ncol, rowmaxnnz) + !initial the sparse matrix. This subroutine + !acts a method for a sparse matrix by initializing + !the row data. It presently requires one maximum + !value for all rows, however, this can be changed + !to a vector of maximum values with one value for + !each row. + ! -- dummy + class(sparsematrix), intent(inout) :: this + integer(I4B), intent(in) :: nrow, ncol + integer(I4B), intent(in), dimension(nrow) :: rowmaxnnz + ! -- local + integer(I4B) :: i + ! -- code + this%nrow = nrow + this%ncol = ncol + this%nnz = 0 + allocate (this%row(nrow)) + do i = 1, nrow + allocate (this%row(i)%icolarray(rowmaxnnz(i))) + this%row(i)%icolarray = 0 + this%row(i)%nnz = 0 + end do + ! + ! -- return + return + end subroutine initialize - do i=1,nrow - rowmaxnnz(i) = maxnnz - enddo + ! overload + subroutine initializefixed(this, nrow, ncol, maxnnz) + implicit none + class(sparsematrix), intent(inout) :: this + integer(I4B), intent(in) :: nrow, ncol + integer(I4B), intent(in) :: maxnnz + ! local + integer(I4B), dimension(:), allocatable :: rowmaxnnz + integer(I4B) :: i - call this%initialize(nrow, ncol, rowmaxnnz) - deallocate(rowmaxnnz) + allocate (rowmaxnnz(nrow)) - end subroutine initializefixed + do i = 1, nrow + rowmaxnnz(i) = maxnnz + end do - subroutine filliaja(this, ia, ja, ierror, sort) - !allocate and fill the ia and ja arrays using information - !from the sparsematrix. - !ierror is returned as: - ! 0 if no error - ! 1 if ia is not the correct size - ! 2 if ja is not the correct size - ! 3 if both ia and ja are not correct size - ! -- dummy - class(sparsematrix), intent(inout) :: this - integer(I4B),dimension(:),intent(inout) :: ia, ja - integer(I4B),intent(inout) :: ierror - logical, intent(in), optional :: sort - ! -- local - logical :: sortja - integer(I4B) :: i,j,ipos - ! -- code - ! - ! -- process optional dummy variables - if (present(sort)) then - sortja = sort - else - sortja = .FALSE. - end if - ! - ! -- initialize error variable - ierror = 0 - ! - ! -- check for error conditions - if (ubound(ia,dim=1) /= this%nrow+1) then - ierror = 1 - end if - if (ubound(ja,dim=1) /= this%nnz) then - ierror = ierror + 2 - end if - if (ierror/=0) then - return - end if - ! - ! -- sort this - if (sortja) then - call this%sort() - end if - ! - ! -- fill ia and ja - ipos = 1 - ia(1) = ipos - do i = 1, this%nrow - do j = 1, this%row(i)%nnz - ja(ipos) = this%row(i)%icolarray(j) - ipos = ipos + 1 - end do - ia(i+1) = ipos - end do - ! - ! -- return - return - end subroutine filliaja + call this%initialize(nrow, ncol, rowmaxnnz) + deallocate (rowmaxnnz) + + end subroutine initializefixed - subroutine addconnection(this, i, j, inodup, iaddop) - !add a connection to the sparsematrix. if inodup - !(for no duplicates) is 1, then j is added only - !if it is unique. - ! -- dummy - class(sparsematrix), intent(inout) :: this - integer(I4B),intent(in) :: i, j, inodup - integer(I4B),optional,intent(inout) :: iaddop - ! -- local - integer(I4B) :: iadded - ! -- code - call insert(j, this%row(i), inodup, iadded) - this%nnz = this%nnz+iadded - if (present(iaddop)) iaddop = iadded - ! - ! -- return + subroutine filliaja(this, ia, ja, ierror, sort) + !allocate and fill the ia and ja arrays using information + !from the sparsematrix. + !ierror is returned as: + ! 0 if no error + ! 1 if ia is not the correct size + ! 2 if ja is not the correct size + ! 3 if both ia and ja are not correct size + ! -- dummy + class(sparsematrix), intent(inout) :: this + integer(I4B), dimension(:), intent(inout) :: ia, ja + integer(I4B), intent(inout) :: ierror + logical, intent(in), optional :: sort + ! -- local + logical :: sortja + integer(I4B) :: i, j, ipos + ! -- code + ! + ! -- process optional dummy variables + if (present(sort)) then + sortja = sort + else + sortja = .FALSE. + end if + ! + ! -- initialize error variable + ierror = 0 + ! + ! -- check for error conditions + if (ubound(ia, dim=1) /= this%nrow + 1) then + ierror = 1 + end if + if (ubound(ja, dim=1) /= this%nnz) then + ierror = ierror + 2 + end if + if (ierror /= 0) then return - end subroutine addconnection + end if + ! + ! -- sort this + if (sortja) then + call this%sort() + end if + ! + ! -- fill ia and ja + ipos = 1 + ia(1) = ipos + do i = 1, this%nrow + do j = 1, this%row(i)%nnz + ja(ipos) = this%row(i)%icolarray(j) + ipos = ipos + 1 + end do + ia(i + 1) = ipos + end do + ! + ! -- return + return + end subroutine filliaja + + subroutine addconnection(this, i, j, inodup, iaddop) + !add a connection to the sparsematrix. if inodup + !(for no duplicates) is 1, then j is added only + !if it is unique. + ! -- dummy + class(sparsematrix), intent(inout) :: this + integer(I4B), intent(in) :: i, j, inodup + integer(I4B), optional, intent(inout) :: iaddop + ! -- local + integer(I4B) :: iadded + ! -- code + call insert(j, this%row(i), inodup, iadded) + this%nnz = this%nnz + iadded + if (present(iaddop)) iaddop = iadded + ! + ! -- return + return + end subroutine addconnection - subroutine insert(j, thisrow, inodup, iadded) - !insert j into thisrow (for row i) - !inodup=1 means do not include duplicate connections - !iadded is 1 if a new entry was added (meaning that nnz for the row was increased) - !iadded is 0 if duplicate and not added. Used to track total number of connections - ! -- dummy - integer(I4B), intent(in) :: j, inodup - type(rowtype), intent(inout) :: thisrow - integer(I4B), allocatable,dimension(:) :: iwk - integer(I4B), intent(inout) :: iadded - ! -- local - integer(I4B) :: jj, maxnnz - ! -- code - iadded = 0 - maxnnz = ubound(thisrow%icolarray,dim=1) - if (thisrow%icolarray(1) == 0) then - thisrow%icolarray(1) = j - thisrow%nnz = thisrow%nnz + 1 - iadded = 1 - return - end if - if (thisrow%nnz == maxnnz) then - ! -- increase size of the row - allocate(iwk(thisrow%nnz)) - iwk = thisrow%icolarray - deallocate(thisrow%icolarray) - ! -- Specify how to increase the size of the icolarray. Adding 1 - ! will be most memory conservative, but may be a little slower - ! due to frequent allocate/deallocate. Another option would be - ! to double the size: maxnnz=maxnnz*2 - maxnnz = maxnnz + 1 - allocate(thisrow%icolarray(maxnnz)) - thisrow%icolarray(1:thisrow%nnz) = iwk(1:thisrow%nnz) - thisrow%icolarray(thisrow%nnz+1:maxnnz) = 0 - end if - if (inodup == 1) then - do jj = 1, thisrow%nnz - if (thisrow%icolarray(jj)==j) then - return - end if - end do - end if - ! - ! -- add the connection to end + subroutine insert(j, thisrow, inodup, iadded) + !insert j into thisrow (for row i) + !inodup=1 means do not include duplicate connections + !iadded is 1 if a new entry was added (meaning that nnz for the row was increased) + !iadded is 0 if duplicate and not added. Used to track total number of connections + ! -- dummy + integer(I4B), intent(in) :: j, inodup + type(rowtype), intent(inout) :: thisrow + integer(I4B), allocatable, dimension(:) :: iwk + integer(I4B), intent(inout) :: iadded + ! -- local + integer(I4B) :: jj, maxnnz + ! -- code + iadded = 0 + maxnnz = ubound(thisrow%icolarray, dim=1) + if (thisrow%icolarray(1) == 0) then + thisrow%icolarray(1) = j thisrow%nnz = thisrow%nnz + 1 - thisrow%icolarray(thisrow%nnz) = j iadded = 1 - ! - ! -- return return - end subroutine insert - - subroutine sort(this) - !sort the icolarray for each row, but do not include - !the diagonal position in the sort so that it stays in front - ! -- dummy - class(sparsematrix), intent(inout) :: this - ! -- local - integer(I4B) :: i, nval - ! -- code - do i = 1, this%nrow - nval = this%row(i)%nnz - call sortintarray(nval-1, & - this%row(i)%icolarray(2:nval)) + end if + if (thisrow%nnz == maxnnz) then + ! -- increase size of the row + allocate (iwk(thisrow%nnz)) + iwk = thisrow%icolarray + deallocate (thisrow%icolarray) + ! -- Specify how to increase the size of the icolarray. Adding 1 + ! will be most memory conservative, but may be a little slower + ! due to frequent allocate/deallocate. Another option would be + ! to double the size: maxnnz=maxnnz*2 + maxnnz = maxnnz + 1 + allocate (thisrow%icolarray(maxnnz)) + thisrow%icolarray(1:thisrow%nnz) = iwk(1:thisrow%nnz) + thisrow%icolarray(thisrow%nnz + 1:maxnnz) = 0 + end if + if (inodup == 1) then + do jj = 1, thisrow%nnz + if (thisrow%icolarray(jj) == j) then + return + end if end do - ! - ! -- return - return - end subroutine sort + end if + ! + ! -- add the connection to end + thisrow%nnz = thisrow%nnz + 1 + thisrow%icolarray(thisrow%nnz) = j + iadded = 1 + ! + ! -- return + return + end subroutine insert - subroutine sortintarray(nval,iarray) - !simple subroutine for sorting an array - !in place. It is not the fastest sort function - !but should suffice for relatively short nodelists. - ! -- dummy - integer(I4B),intent(in) :: nval - integer(I4B),intent(inout),dimension(nval) :: iarray - ! -- local - integer(I4B) :: i, j, itemp - ! -- code - do i = 1, nval-1 - do j = i+1, nval - if (iarray(i) > iarray(j)) then - itemp = iarray(j) - iarray(j) = iarray(i) - iarray(i) = itemp - end if - end do + subroutine sort(this) + !sort the icolarray for each row, but do not include + !the diagonal position in the sort so that it stays in front + ! -- dummy + class(sparsematrix), intent(inout) :: this + ! -- local + integer(I4B) :: i, nval + ! -- code + do i = 1, this%nrow + nval = this%row(i)%nnz + call sortintarray(nval - 1, & + this%row(i)%icolarray(2:nval)) + end do + ! + ! -- return + return + end subroutine sort + + subroutine sortintarray(nval, iarray) + !simple subroutine for sorting an array + !in place. It is not the fastest sort function + !but should suffice for relatively short nodelists. + ! -- dummy + integer(I4B), intent(in) :: nval + integer(I4B), intent(inout), dimension(nval) :: iarray + ! -- local + integer(I4B) :: i, j, itemp + ! -- code + do i = 1, nval - 1 + do j = i + 1, nval + if (iarray(i) > iarray(j)) then + itemp = iarray(j) + iarray(j) = iarray(i) + iarray(i) = itemp + end if end do - ! - ! -- return - return - end subroutine sortintarray + end do + ! + ! -- return + return + end subroutine sortintarray - subroutine csr_diagsum(ia, flowja) - !Add up the off diagonal terms and put the sum in the - !diagonal position - ! -- dummy - integer(I4B), dimension(:), contiguous :: ia - real(DP), dimension(:), contiguous :: flowja - ! -- local - integer(I4B) :: nodes - integer(I4B) :: n - integer(I4B) :: iposdiag - integer(I4B) :: ipos - ! -- code - nodes = size(ia) - 1 - do n = 1, nodes - iposdiag = ia(n) - do ipos = ia(n) + 1, ia(n + 1) - 1 - flowja(iposdiag) = flowja(iposdiag) + flowja(ipos) - end do + subroutine csr_diagsum(ia, flowja) + !Add up the off diagonal terms and put the sum in the + !diagonal position + ! -- dummy + integer(I4B), dimension(:), contiguous :: ia + real(DP), dimension(:), contiguous :: flowja + ! -- local + integer(I4B) :: nodes + integer(I4B) :: n + integer(I4B) :: iposdiag + integer(I4B) :: ipos + ! -- code + nodes = size(ia) - 1 + do n = 1, nodes + iposdiag = ia(n) + do ipos = ia(n) + 1, ia(n + 1) - 1 + flowja(iposdiag) = flowja(iposdiag) + flowja(ipos) end do - return - end subroutine csr_diagsum + end do + return + end subroutine csr_diagsum end module SparseModule diff --git a/src/Utilities/StringList.f90 b/src/Utilities/StringList.f90 index 1ee9cbdffe8..4fd67c2e923 100644 --- a/src/Utilities/StringList.f90 +++ b/src/Utilities/StringList.f90 @@ -1,5 +1,5 @@ module StringListModule - + use KindModule, only: DP, I4B use ListModule, only: ListType @@ -12,17 +12,17 @@ module StringListModule contains - subroutine ConstructCharacterContainer (newCharCont, text) + subroutine ConstructCharacterContainer(newCharCont, text) implicit none type(CharacterContainerType), pointer, intent(out) :: newCharCont character(len=*), intent(in) :: text ! - allocate(newCharCont) + allocate (newCharCont) newCharCont%charstring = text return end subroutine ConstructCharacterContainer - function CastAsCharacterContainerType(obj) result (res) + function CastAsCharacterContainerType(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj type(CharacterContainerType), pointer :: res @@ -51,12 +51,12 @@ subroutine AddStringToList(list, string) if (associated(newCharacterContainer)) then obj => newCharacterContainer call list%Add(obj) - endif + end if ! return end subroutine AddStringToList - - function GetStringFromList(list, indx) result (string) + + function GetStringFromList(list, indx) result(string) implicit none ! -- dummy type(ListType), intent(inout) :: list @@ -71,7 +71,7 @@ function GetStringFromList(list, indx) result (string) charcont => CastAsCharacterContainerType(obj) if (associated(charcont)) then string = charcont%charstring - endif + end if ! return end function GetStringFromList diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 7d46f215712..b7e119621eb 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -1,22 +1,22 @@ -! Comprehensive table object that stores all of the -! intercell flows, and the inflows and the outflows for +! Comprehensive table object that stores all of the +! intercell flows, and the inflows and the outflows for ! an advanced package. module TableModule - + use KindModule, only: I4B, I8B, DP - use ConstantsModule, only: LINELENGTH, LENBUDTXT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + use ConstantsModule, only: LINELENGTH, LENBUDTXT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & TABCENTER use TableTermModule, only: TableTermType use InputOutputModule, only: UWWORD, parseline use SimModule, only: store_error use SimVariablesModule, only: errmsg - + implicit none - + public :: TableType public :: table_cr - + type :: TableType ! ! -- name, number of control volumes, and number of table terms @@ -45,18 +45,18 @@ module TableModule ! ! -- table table object, for writing the typical MODFLOW table type(TableType), pointer :: table => null() - + character(len=LINELENGTH), pointer :: linesep => null() character(len=LINELENGTH), pointer :: dataline => null() character(len=LINELENGTH), dimension(:), pointer :: header => null() - - contains - + + contains + procedure :: table_df procedure :: table_da procedure :: initialize_column procedure :: line_to_columns - procedure :: finalize_table + procedure :: finalize_table procedure :: set_maxbound procedure :: set_kstpkper procedure :: set_title @@ -65,20 +65,20 @@ module TableModule procedure :: print_separator procedure, private :: allocate_strings - procedure, private :: set_header - procedure, private :: write_header - procedure, private :: write_line + procedure, private :: set_header + procedure, private :: write_header + procedure, private :: write_line procedure, private :: finalize procedure, private :: add_error procedure, private :: reset - - generic, public :: add_term => add_integer, add_long_integer, & - add_real, add_string - procedure, private :: add_integer, add_long_integer, add_real, add_string + + generic, public :: add_term => add_integer, add_long_integer, & + add_real, add_string + procedure, private :: add_integer, add_long_integer, add_real, add_string end type TableType - - contains + +contains subroutine table_cr(this, name, title) ! ****************************************************************************** @@ -98,12 +98,12 @@ subroutine table_cr(this, name, title) ! -- check if table already associated and reset if necessary if (associated(this)) then call this%table_da() - deallocate(this) - nullify(this) + deallocate (this) + nullify (this) end if ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- initialize variables this%name = name @@ -113,7 +113,7 @@ subroutine table_cr(this, name, title) return end subroutine table_cr - subroutine table_df(this, maxbound, ntableterm, iout, transient, & + subroutine table_df(this, maxbound, ntableterm, iout, transient, & lineseparator, separator, finalize) ! ****************************************************************************** ! table_df -- Define the new table object @@ -134,29 +134,29 @@ subroutine table_df(this, maxbound, ntableterm, iout, transient, & ! ------------------------------------------------------------------------------ ! ! -- allocate scalars - allocate(this%sep) - allocate(this%write_csv) - allocate(this%first_entry) - allocate(this%transient) - allocate(this%add_linesep) - allocate(this%allow_finalization) - allocate(this%iout) - allocate(this%maxbound) - allocate(this%nheaderlines) - allocate(this%nlinewidth) - allocate(this%ntableterm) - allocate(this%ientry) - allocate(this%iloc) - allocate(this%icount) + allocate (this%sep) + allocate (this%write_csv) + allocate (this%first_entry) + allocate (this%transient) + allocate (this%add_linesep) + allocate (this%allow_finalization) + allocate (this%iout) + allocate (this%maxbound) + allocate (this%nheaderlines) + allocate (this%nlinewidth) + allocate (this%ntableterm) + allocate (this%ientry) + allocate (this%iloc) + allocate (this%icount) ! ! -- allocate space for tableterm - allocate(this%tableterm(ntableterm)) + allocate (this%tableterm(ntableterm)) ! ! -- initialize values based on optional dummy variables if (present(transient)) then this%transient = transient - allocate(this%kstp) - allocate(this%kper) + allocate (this%kstp) + allocate (this%kper) else this%transient = .FALSE. end if @@ -193,7 +193,7 @@ subroutine table_df(this, maxbound, ntableterm, iout, transient, & ! -- return return end subroutine table_df - + subroutine initialize_column(this, text, width, alignment) ! ****************************************************************************** ! initialize_column -- Initialize data for a column @@ -225,16 +225,16 @@ subroutine initialize_column(this, text, width, alignment) ! ! -- check that ientry is in bounds if (this%ientry > this%ntableterm) then - write(errmsg,'(a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & - 'Trying to add column "', trim(adjustl(text)), '" (', & - this%ientry, ') in the', trim(adjustl(this%name)), 'table ("', & - trim(adjustl(this%title)), '") that only has', this%ntableterm, & + write (errmsg, '(a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & + 'Trying to add column "', trim(adjustl(text)), '" (', & + this%ientry, ') in the', trim(adjustl(this%name)), 'table ("', & + trim(adjustl(this%title)), '") that only has', this%ntableterm, & 'columns.' call store_error(errmsg, terminate=.TRUE.) end if ! ! -- initialize table term - call this%tableterm(idx)%initialize(text, width, alignment=ialign) + call this%tableterm(idx)%initialize(text, width, alignment=ialign) ! ! -- create header when all terms have been specified if (this%ientry == this%ntableterm) then @@ -247,7 +247,7 @@ subroutine initialize_column(this, text, width, alignment) ! -- return return end subroutine initialize_column - + subroutine set_header(this) ! ****************************************************************************** ! set_header -- Set the table object header @@ -306,19 +306,19 @@ subroutine set_header(this) alignment = this%tableterm(j)%get_alignment() call this%tableterm(j)%get_header(n, cval) if (this%write_csv) then - if ( j == 1) then - write(this%header(nn), '(a)') trim(adjustl(cval)) + if (j == 1) then + write (this%header(nn), '(a)') trim(adjustl(cval)) else - write(this%header(nn), '(a,",",G0)') & + write (this%header(nn), '(a,",",G0)') & trim(this%header(nn)), trim(adjustl(cval)) end if else if (j == this%ntableterm) then - call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & - cval(1:width), ival, rval, ALIGNMENT=alignment) + call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & + cval(1:width), ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & - cval(1:width), ival, rval, ALIGNMENT=alignment, & + call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & + cval(1:width), ival, rval, ALIGNMENT=alignment, & SEP=this%sep) end if end if @@ -328,7 +328,7 @@ subroutine set_header(this) ! -- return return end subroutine set_header - + subroutine allocate_strings(this, width, nlines) ! ****************************************************************************** ! allocate_strings -- Allocate allocatable character arrays @@ -359,9 +359,9 @@ subroutine allocate_strings(this, width, nlines) this%nlinewidth = width ! ! -- allocate deferred length strings - allocate(this%header(this%nheaderlines)) - allocate(this%linesep) - allocate(this%dataline) + allocate (this%header(this%nheaderlines)) + allocate (this%linesep) + allocate (this%dataline) ! ! -- initialize lines this%linesep = linesep(1:width) @@ -374,12 +374,12 @@ subroutine allocate_strings(this, width, nlines) ! linesep if (this%add_linesep) then this%header(1) = linesep(1:width) - this%header(nlines+2) = linesep(1:width) + this%header(nlines + 2) = linesep(1:width) end if ! ! -- return return - end subroutine allocate_strings + end subroutine allocate_strings subroutine write_header(this) ! ****************************************************************************** @@ -405,16 +405,16 @@ subroutine write_header(this) ! -- write title title = this%title if (this%transient) then - write(title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', this%kper - write(title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', this%kstp + write (title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', this%kper + write (title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', this%kstp end if if (len_trim(title) > 0) then - write(this%iout, '(/,1x,a)') trim(adjustl(title)) + write (this%iout, '(/,1x,a)') trim(adjustl(title)) end if ! ! -- write header do n = 1, this%nheaderlines - write(this%iout, '(1x,a)') this%header(n)(1:width) + write (this%iout, '(1x,a)') this%header(n) (1:width) end do end if ! @@ -426,7 +426,7 @@ subroutine write_header(this) ! -- return return end subroutine write_header - + subroutine write_line(this) ! ****************************************************************************** ! write_line -- Write the data line @@ -445,7 +445,7 @@ subroutine write_line(this) width = this%nlinewidth ! ! -- write the dataline - write(this%iout, '(1x,a)') this%dataline(1:width) + write (this%iout, '(1x,a)') this%dataline(1:width) ! ! -- update column and line counters this%ientry = 0 @@ -455,11 +455,11 @@ subroutine write_line(this) ! -- return return end subroutine write_line - + subroutine finalize(this) ! ****************************************************************************** ! finalize -- Private method that test for last line. If last line the -! public finalize_table method is called +! public finalize_table method is called ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -478,7 +478,7 @@ subroutine finalize(this) ! -- return return end subroutine finalize - + subroutine finalize_table(this) ! ****************************************************************************** ! finalize -- Public method to finalize the table @@ -496,14 +496,14 @@ subroutine finalize_table(this) call this%print_separator(iextralines=1) ! ! -- flush file - flush(this%iout) + flush (this%iout) ! ! -- reinitialize variables call this%reset() ! ! -- return return - end subroutine finalize_table + end subroutine finalize_table subroutine table_da(this) ! ****************************************************************************** @@ -525,37 +525,37 @@ subroutine table_da(this) end do ! ! -- deallocate space for tableterm - deallocate(this%tableterm) + deallocate (this%tableterm) ! ! -- deallocate character scalars and arrays - deallocate(this%linesep) - deallocate(this%dataline) - deallocate(this%header) + deallocate (this%linesep) + deallocate (this%dataline) + deallocate (this%header) ! ! -- deallocate scalars if (this%transient) then - deallocate(this%kstp) - deallocate(this%kper) + deallocate (this%kstp) + deallocate (this%kper) end if - deallocate(this%sep) - deallocate(this%write_csv) - deallocate(this%first_entry) - deallocate(this%transient) - deallocate(this%add_linesep) - deallocate(this%allow_finalization) - deallocate(this%iout) - deallocate(this%maxbound) - deallocate(this%nheaderlines) - deallocate(this%nlinewidth) - deallocate(this%ntableterm) - deallocate(this%ientry) - deallocate(this%iloc) - deallocate(this%icount) + deallocate (this%sep) + deallocate (this%write_csv) + deallocate (this%first_entry) + deallocate (this%transient) + deallocate (this%add_linesep) + deallocate (this%allow_finalization) + deallocate (this%iout) + deallocate (this%maxbound) + deallocate (this%nheaderlines) + deallocate (this%nlinewidth) + deallocate (this%ntableterm) + deallocate (this%ientry) + deallocate (this%iloc) + deallocate (this%icount) ! ! -- Return return end subroutine table_da - + subroutine line_to_columns(this, line) ! ****************************************************************************** ! line_to_columns -- convert a line to the correct number of columns @@ -599,12 +599,12 @@ subroutine line_to_columns(this, line) end do ! ! -- clean up local allocatable array - deallocate(words) + deallocate (words) ! ! -- Return return - end subroutine line_to_columns - + end subroutine line_to_columns + subroutine add_error(this) ! ****************************************************************************** ! add_error -- evaluate if error condition occurs when adding data to dataline @@ -620,9 +620,9 @@ subroutine add_error(this) ! ! -- check that ientry is within bounds if (this%ientry > this%ntableterm) then - write(errmsg,'(a,1x,i0,5(1x,a),1x,i0,1x,a)') & - 'Trying to add data to column ', this%ientry, 'in the', & - trim(adjustl(this%name)), 'table (', trim(adjustl(this%title)), & + write (errmsg, '(a,1x,i0,5(1x,a),1x,i0,1x,a)') & + 'Trying to add data to column ', this%ientry, 'in the', & + trim(adjustl(this%name)), 'table (', trim(adjustl(this%title)), & ') that only has', this%ntableterm, 'columns.' call store_error(errmsg, terminate=.TRUE.) end if @@ -630,7 +630,7 @@ subroutine add_error(this) ! -- Return return end subroutine add_error - + subroutine add_integer(this, ival) ! ****************************************************************************** ! add_integer -- add integer value to the dataline @@ -674,16 +674,16 @@ subroutine add_integer(this, ival) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(G0)') ival + write (this%dataline, '(G0)') ival else - write(this%dataline, '(a,",",G0)') trim(this%dataline), ival + write (this%dataline, '(a,",",G0)') trim(this%dataline), ival end if else if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & + call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & cval, ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & + call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -701,7 +701,7 @@ subroutine add_integer(this, ival) ! -- Return return end subroutine add_integer - + subroutine add_long_integer(this, long_ival) ! ****************************************************************************** ! add_long_integer -- add long integer value to the dataline @@ -746,17 +746,17 @@ subroutine add_long_integer(this, long_ival) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(G0)') long_ival + write (this%dataline, '(G0)') long_ival else - write(this%dataline, '(a,",",G0)') trim(this%dataline), long_ival + write (this%dataline, '(a,",",G0)') trim(this%dataline), long_ival end if else - write(cval, '(i0)') long_ival + write (cval, '(i0)') long_ival if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & trim(cval), ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & trim(cval), ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -818,16 +818,16 @@ subroutine add_real(this, rval) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(G0)') rval + write (this%dataline, '(G0)') rval else - write(this%dataline, '(a,",",G0)') trim(this%dataline), rval + write (this%dataline, '(a,",",G0)') trim(this%dataline), rval end if else if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABREAL, & + call UWWORD(this%dataline, this%iloc, width, TABREAL, & cval, ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABREAL, & + call UWWORD(this%dataline, this%iloc, width, TABREAL, & cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -845,7 +845,7 @@ subroutine add_real(this, rval) ! -- Return return end subroutine add_real - + subroutine add_string(this, cval) ! ****************************************************************************** ! add_string -- add string value to the dataline @@ -889,17 +889,17 @@ subroutine add_string(this, cval) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(a)') trim(adjustl(cval)) + write (this%dataline, '(a)') trim(adjustl(cval)) else - write(this%dataline, '(a,",",a)') & + write (this%dataline, '(a,",",a)') & trim(this%dataline), trim(adjustl(cval)) end if else if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & cval, ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -917,7 +917,7 @@ subroutine add_string(this, cval) ! -- Return return end subroutine add_string - + subroutine set_maxbound(this, maxbound) ! ****************************************************************************** ! set_maxbound -- reset maxbound @@ -940,8 +940,8 @@ subroutine set_maxbound(this, maxbound) ! ! -- return return - end subroutine set_maxbound - + end subroutine set_maxbound + subroutine set_kstpkper(this, kstp, kper) ! ****************************************************************************** ! set_kstpkper -- reset kstp and kper @@ -963,8 +963,8 @@ subroutine set_kstpkper(this, kstp, kper) ! ! -- return return - end subroutine set_kstpkper - + end subroutine set_kstpkper + subroutine set_title(this, title) ! ****************************************************************************** ! set_maxbound -- reset maxbound @@ -985,7 +985,7 @@ subroutine set_title(this, title) ! -- return return end subroutine set_title - + subroutine set_iout(this, iout) ! ****************************************************************************** ! set_iout -- reset iout @@ -1005,8 +1005,8 @@ subroutine set_iout(this, iout) ! ! -- return return - end subroutine set_iout - + end subroutine set_iout + subroutine print_list_entry(this, i, nodestr, q, bname) ! ****************************************************************************** ! print_list_entry -- write flow term table values @@ -1034,8 +1034,8 @@ subroutine print_list_entry(this, i, nodestr, q, bname) ! ! -- return return - end subroutine print_list_entry - + end subroutine print_list_entry + subroutine print_separator(this, iextralines) ! ****************************************************************************** ! print_separator -- print a line separator to the table @@ -1065,16 +1065,16 @@ subroutine print_separator(this, iextralines) ! ! -- print line separator if (this%add_linesep) then - write(this%iout, '(1x,a)') this%linesep(1:width) + write (this%iout, '(1x,a)') this%linesep(1:width) do i = 1, iextra - write(this%iout, '(/)') + write (this%iout, '(/)') end do end if ! ! -- return return end subroutine print_separator - + subroutine reset(this) ! ****************************************************************************** ! reset -- Private method to reset table counters @@ -1095,6 +1095,6 @@ subroutine reset(this) ! ! -- return return - end subroutine reset + end subroutine reset end module TableModule diff --git a/src/Utilities/TableTerm.f90 b/src/Utilities/TableTerm.f90 index f00d1cc7cd1..f7e5e3c9cc8 100644 --- a/src/Utilities/TableTerm.f90 +++ b/src/Utilities/TableTerm.f90 @@ -1,31 +1,30 @@ ! A table term is the information needed to describe flow. -! The table object contains an array of table terms. -! For an advanced package. The table object describes all of +! The table object contains an array of table terms. +! For an advanced package. The table object describes all of ! the flows. module TableTermModule use KindModule, only: I4B, DP - use ConstantsModule, only: LINELENGTH, LENBUDTXT, DZERO, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use ConstantsModule, only: LINELENGTH, LENBUDTXT, DZERO, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL use InputOutputModule, only: UPCASE, parseline implicit none public :: TableTermType - - + type :: TableTermType character(len=LINELENGTH), pointer :: tag => null() integer(I4B), pointer :: width => null() integer(I4B), pointer :: alignment => null() integer(I4B), pointer :: nheader_lines => null() - + character(len=LINELENGTH), dimension(:), pointer :: initial_lines => null() character(len=LINELENGTH), dimension(:), pointer :: header_lines => null() - + contains - + procedure :: initialize procedure, private :: allocate_scalars procedure :: get_width @@ -34,12 +33,11 @@ module TableTermModule procedure :: set_header procedure :: get_header procedure :: da - - + end type TableTermType - contains - +contains + subroutine initialize(this, tag, width, alignment) ! ****************************************************************************** ! initialize -- initialize the table term @@ -66,16 +64,16 @@ subroutine initialize(this, tag, width, alignment) ! ! -- allocate scalars call this%allocate_scalars() - + ! -- process dummy variables this%tag = tag - + if (present(alignment)) then this%alignment = alignment else this%alignment = TABCENTER end if - + this%width = width ! ! -- parse tag into words @@ -86,16 +84,16 @@ subroutine initialize(this, tag, width, alignment) do i = 1, nwords ilen = len(trim(words(i))) if (ilen > width) then - words(i)(width:width) = '.' + words(i) (width:width) = '.' do j = width + 1, ilen - words(i)(j:j) = ' ' + words(i) (j:j) = ' ' end do end if end do ! ! -- combine words that fit into width i = 0 - do + do i = i + 1 if (i > nwords) then exit @@ -104,7 +102,7 @@ subroutine initialize(this, tag, width, alignment) tstring = string do j = i + 1, nwords if (len(trim(adjustl(string))) > 0) then - tstring = trim(adjustl(tstring)) // ' ' // trim(adjustl(words(j))) + tstring = trim(adjustl(tstring))//' '//trim(adjustl(words(j))) else tstring = trim(adjustl(words(j))) end if @@ -130,22 +128,22 @@ subroutine initialize(this, tag, width, alignment) end do ! ! allocate initial_lines and fill with words - allocate(this%initial_lines(this%nheader_lines)) - do i = 1, this%nheader_lines - this%initial_lines(i) = words(i)(1:width) + allocate (this%initial_lines(this%nheader_lines)) + do i = 1, this%nheader_lines + this%initial_lines(i) = words(i) (1:width) end do ! ! -- deallocate words - deallocate(words) + deallocate (words) ! ! -- return return end subroutine initialize - + function get_width(this) ! ****************************************************************************** -! get_width -- get column width +! get_width -- get column width ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -162,10 +160,10 @@ function get_width(this) ! -- return return end function get_width - + function get_alignment(this) ! ****************************************************************************** -! get_width -- get column width +! get_width -- get column width ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -181,8 +179,8 @@ function get_alignment(this) ! ! -- return return - end function get_alignment - + end function get_alignment + function get_header_lines(this) ! ****************************************************************************** ! get_header_lines -- get the number of lines in initial_lines @@ -202,7 +200,7 @@ function get_header_lines(this) ! -- return return end function get_header_lines - + subroutine allocate_scalars(this) ! ****************************************************************************** ! allocate_scalars -- allocate table term scalars @@ -216,10 +214,10 @@ subroutine allocate_scalars(this) ! ------------------------------------------------------------------------------ ! ! -- allocate scalars - allocate(this%tag) - allocate(this%alignment) - allocate(this%width) - allocate(this%nheader_lines) + allocate (this%tag) + allocate (this%alignment) + allocate (this%width) + allocate (this%nheader_lines) ! ! -- initialize scalars this%nheader_lines = 0 @@ -227,7 +225,7 @@ subroutine allocate_scalars(this) ! -- return return end subroutine allocate_scalars - + subroutine da(this) ! ****************************************************************************** ! da -- deallocate table terms @@ -242,16 +240,16 @@ subroutine da(this) !integer(I4B) :: n ! ------------------------------------------------------------------------------ ! - ! -- deallocate scalars - deallocate(this%tag) - deallocate(this%alignment) - deallocate(this%width) - deallocate(this%nheader_lines) - deallocate(this%header_lines) + ! -- deallocate scalars + deallocate (this%tag) + deallocate (this%alignment) + deallocate (this%width) + deallocate (this%nheader_lines) + deallocate (this%header_lines) ! ! -- return end subroutine da - + subroutine set_header(this, nlines) ! ****************************************************************************** ! set_header -- set final header lines for table term @@ -274,8 +272,8 @@ subroutine set_header(this, nlines) ! -- initialize variables string = ' ' ! - ! allocate header_lines - allocate(this%header_lines(nlines)) + ! allocate header_lines + allocate (this%header_lines(nlines)) ! ! -- initialize header lines do i = 1, nlines @@ -286,20 +284,20 @@ subroutine set_header(this, nlines) ! bottom to top idiff = nlines - this%nheader_lines i0 = 1 - idiff - do i = this%nheader_lines, 1, -1 + do i = this%nheader_lines, 1, -1 j = i + idiff this%header_lines(j) = this%initial_lines(i) end do ! ! -- deallocate temporary header lines - deallocate(this%initial_lines) + deallocate (this%initial_lines) ! ! -- reinitialize nheader_lines this%nheader_lines = nlines ! ! -- return end subroutine set_header - + subroutine get_header(this, iline, cval) ! ****************************************************************************** ! get_header -- get header entry for table term iline @@ -317,9 +315,9 @@ subroutine get_header(this, iline, cval) ! ------------------------------------------------------------------------------ ! ! -- set return value - cval = this%header_lines(iline)(1:this%width) + cval = this%header_lines(iline) (1:this%width) ! ! -- return - end subroutine get_header - -end module TableTermModule \ No newline at end of file + end subroutine get_header + +end module TableTermModule diff --git a/src/Utilities/TimeSeries/TimeArray.f90 b/src/Utilities/TimeSeries/TimeArray.f90 index 15da0224f6e..49b7ee99e4c 100644 --- a/src/Utilities/TimeSeries/TimeArray.f90 +++ b/src/Utilities/TimeSeries/TimeArray.f90 @@ -1,10 +1,10 @@ module TimeArrayModule - use BaseDisModule, only: DisBaseType - use KindModule, only: DP, I4B - use ListModule, only: ListType + use BaseDisModule, only: DisBaseType + use KindModule, only: DP, I4B + use ListModule, only: ListType use SimVariablesModule, only: errmsg - use SimModule, only: store_error + use SimModule, only: store_error implicit none private @@ -37,7 +37,7 @@ subroutine ConstructTimeArray(newTa, dis) ! ------------------------------------------------------------------------------ ! -- dummy type(TimeArrayType), pointer, intent(out) :: newTa - class(DisBaseType), pointer, intent(in) :: dis + class(DisBaseType), pointer, intent(in) :: dis ! -- local integer(I4B) :: isize ! ------------------------------------------------------------------------------ @@ -48,9 +48,9 @@ subroutine ConstructTimeArray(newTa, dis) else errmsg = 'Time array series is not supported for discretization type' call store_error(errmsg, terminate=.TRUE.) - endif - allocate(newTa) - allocate(newTa%taArray(isize)) + end if + allocate (newTa) + allocate (newTa%taArray(isize)) return end subroutine ConstructTimeArray @@ -84,7 +84,7 @@ subroutine AddTimeArrayToList(list, timearray) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeArrayType), pointer, intent(inout) :: timearray ! -- local class(*), pointer :: obj @@ -96,7 +96,7 @@ subroutine AddTimeArrayToList(list, timearray) return end subroutine AddTimeArrayToList - function GetTimeArrayFromList(list, indx) result (res) + function GetTimeArrayFromList(list, indx) result(res) ! ****************************************************************************** ! GetTimeArrayFromList -- get ta from list ! ****************************************************************************** @@ -105,8 +105,8 @@ function GetTimeArrayFromList(list, indx) result (res) ! ------------------------------------------------------------------------------ ! -- dummy type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: indx - type(TimeArrayType), pointer :: res + integer(I4B), intent(in) :: indx + type(TimeArrayType), pointer :: res ! -- local class(*), pointer :: obj ! ------------------------------------------------------------------------------ @@ -128,7 +128,7 @@ subroutine ta_da(this) class(TimeArrayType) :: this ! ------------------------------------------------------------------------------ ! - deallocate(this%taArray) + deallocate (this%taArray) this%taArray => null() ! return diff --git a/src/Utilities/TimeSeries/TimeArraySeries.f90 b/src/Utilities/TimeSeries/TimeArraySeries.f90 index 2aa13b54f4a..34119ffa65a 100644 --- a/src/Utilities/TimeSeries/TimeArraySeries.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeries.f90 @@ -1,25 +1,25 @@ module TimeArraySeriesModule use ArrayReadersModule, only: ReadArray - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & - LENTIMESERIESNAME, DZERO, DONE - use GenericUtilitiesModule, only: is_same - use InputOutputModule, only: GetUnit, openfile - use KindModule, only: DP, I4B - use ListModule, only: ListType, ListNodeType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & + LENTIMESERIESNAME, DZERO, DONE + use GenericUtilitiesModule, only: is_same + use InputOutputModule, only: GetUnit, openfile + use KindModule, only: DP, I4B + use ListModule, only: ListType, ListNodeType use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, store_error_unit - use TimeArrayModule, only: TimeArrayType, ConstructTimeArray, & - AddTimeArrayToList, CastAsTimeArrayType, & - GetTimeArrayFromList - use BaseDisModule, only: DisBaseType + use SimModule, only: count_errors, store_error, store_error_unit + use TimeArrayModule, only: TimeArrayType, ConstructTimeArray, & + AddTimeArrayToList, CastAsTimeArrayType, & + GetTimeArrayFromList + use BaseDisModule, only: DisBaseType use, intrinsic :: iso_fortran_env, only: IOSTAT_END implicit none private - public :: TimeArraySeriesType, ConstructTimeArraySeries, & - CastAsTimeArraySeriesType, GetTimeArraySeriesFromList + public :: TimeArraySeriesType, ConstructTimeArraySeries, & + CastAsTimeArraySeriesType, GetTimeArraySeriesFromList type TimeArraySeriesType ! -- Public members @@ -67,18 +67,18 @@ subroutine ConstructTimeArraySeries(newTas, filename) logical :: lex ! ------------------------------------------------------------------------------ ! formats - 10 format('Error: Time-array-series file "',a,'" does not exist.') +10 format('Error: Time-array-series file "', a, '" does not exist.') ! ! -- Allocate a new object of type TimeArraySeriesType - allocate(newTas) - allocate(newTas%list) + allocate (newTas) + allocate (newTas%list) ! ! -- Ensure that input file exists - inquire(file=filename,exist=lex) + inquire (file=filename, exist=lex) if (.not. lex) then - write(errmsg,10)trim(filename) + write (errmsg, 10) trim(filename) call store_error(errmsg, terminate=.TRUE.) - endif + end if newTas%datafile = filename ! return @@ -99,7 +99,7 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) class(DisBaseType), pointer, intent(inout) :: dis integer(I4B), intent(in) :: iout character(len=*), intent(inout) :: tasname - logical, optional, intent(in) :: autoDeallocate + logical, optional, intent(in) :: autoDeallocate ! -- local integer(I4B) :: istatus integer(I4B) :: ierr @@ -111,7 +111,7 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) ! -- initialize some variables if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate this%dataFile = fname - allocate(this%list) + allocate (this%list) ! ! -- assign members this%dis => dis @@ -131,13 +131,13 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) ! ! -- get BEGIN line of ATTRIBUTES block call this%parser%GetBlock('ATTRIBUTES', found, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (.not. found) then - errmsg = 'Error: Attributes block not found in file: ' // & - trim(fname) + errmsg = 'Error: Attributes block not found in file: '// & + trim(fname) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- parse ATTRIBUTES entries do @@ -161,64 +161,64 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) case ('LINEAR') this%iMethod = LINEAR case default - errmsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' + errmsg = 'Unknown interpolation method: "'//trim(keyvalue)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() end select case ('AUTODEALLOCATE') this%autoDeallocate = (keyvalue == 'TRUE') case ('SFAC') - read(keyvalue,*,iostat=istatus)this%sfac + read (keyvalue, *, iostat=istatus) this%sfac if (istatus /= 0) then - errmsg = 'Error reading numeric SFAC value from "' // trim(keyvalue) & - // '"' + errmsg = 'Error reading numeric SFAC value from "'//trim(keyvalue) & + //'"' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if case default - errmsg = 'Unknown option found in ATTRIBUTES block: "' // & - trim(keyword) // '"' + errmsg = 'Unknown option found in ATTRIBUTES block: "'// & + trim(keyword)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() end select - enddo + end do ! ! -- ensure that NAME and METHOD have been specified if (this%Name == '') then - errmsg = 'Name not specified for time array series in file: ' // & + errmsg = 'Name not specified for time array series in file: '// & trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if if (this%iMethod == UNDEFINED) then - errmsg = 'Interpolation method not specified for time' // & - ' array series in file: ' // trim(this%dataFile) + errmsg = 'Interpolation method not specified for time'// & + ' array series in file: '//trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- handle any errors encountered so far - if (count_errors()>0) then - errmsg = 'Error(s) encountered initializing time array series from file: ' // & - trim(this%dataFile) + if (count_errors() > 0) then + errmsg = 'Error(s) encountered initializing time array series from file: ' & + //trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- try to read first time array into linked list if (.not. this%read_next_array()) then - errmsg = 'Error encountered reading time-array data from file: ' // & + errmsg = 'Error encountered reading time-array data from file: '// & trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! return end subroutine tas_init subroutine GetAverageValues(this, nvals, values, time0, time1) ! ****************************************************************************** -! GetAverageValues -- populate an array time-weighted average value for a +! GetAverageValues -- populate an array time-weighted average value for a ! specified time span. ! ****************************************************************************** ! @@ -226,10 +226,10 @@ subroutine GetAverageValues(this, nvals, values, time0, time1) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals + integer(I4B), intent(in) :: nvals real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 ! -- local integer(I4B) :: i real(DP) :: timediff @@ -238,13 +238,13 @@ subroutine GetAverageValues(this, nvals, values, time0, time1) timediff = time1 - time0 if (timediff > 0) then call this%get_integrated_values(nvals, values, time0, time1) - do i=1,nvals + do i = 1, nvals values(i) = values(i) / timediff - enddo + end do else ! -- time0 and time1 are the same, so skip the integration step. call this%get_values_at_time(nvals, values, time0) - endif + end if ! return end subroutine GetAverageValues @@ -278,7 +278,7 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeArraySeriesType), intent(inout) :: this - real(DP), intent(in) :: time + real(DP), intent(in) :: time type(TimeArrayType), pointer, intent(inout) :: taEarlier type(TimeArrayType), pointer, intent(inout) :: taLater ! -- local @@ -295,7 +295,7 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) ! if (associated(this%list%firstNode)) then currNode => this%list%firstNode - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -308,15 +308,15 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) currNode => currNode%nextNode else exit - endif + end if else ! -- read another array if (.not. this%read_next_array()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -333,8 +333,8 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) time0 = ta0%taTime else exit - endif - enddo + end if + end do ! ! -- find later record node1 => currNode @@ -352,11 +352,11 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) if (.not. this%read_next_array()) then ! -- end of file reached, so exit loop exit - endif - endif - enddo + end if + end if + end do ! - endif + end if ! if (time0 <= time) taEarlier => ta0 if (time1 >= time) taLater => ta1 @@ -376,7 +376,7 @@ logical function read_next_array(this) ! -- local integer(I4B) :: i, ierr, istart, istat, istop, lloc, nrow, ncol, nodesperlayer logical :: lopen, isFound - type(TimeArrayType), pointer :: ta => null() + type(TimeArrayType), pointer :: ta => null() ! ------------------------------------------------------------------------------ ! istart = 1 @@ -386,38 +386,39 @@ logical function read_next_array(this) ! Get dimensions for supported discretization type if (this%dis%supports_layers()) then nodesperlayer = this%dis%get_ncpl() - if(size(this%dis%mshape) == 3) then + if (size(this%dis%mshape) == 3) then nrow = this%dis%mshape(2) ncol = this%dis%mshape(3) else nrow = 1 ncol = this%dis%mshape(2) - endif + end if else - errmsg = 'Time array series is not supported for selected discretization type.' + errmsg = 'Time array series is not supported for selected & + &discretization type.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! read_next_array = .false. - inquire(unit=this%inunit,opened=lopen) + inquire (unit=this%inunit, opened=lopen) if (lopen) then call ConstructTimeArray(ta, this%dis) ! -- read a time and an array from the input file ! -- Get a TIME block and read the time call this%parser%GetBlock('TIME', isFound, ierr, & - supportOpenClose=.false.) + supportOpenClose=.false.) if (isFound) then ta%taTime = this%parser%GetDouble() ! -- Read the array call ReadArray(this%parser%iuactive, ta%taArray, this%Name, & - this%dis%ndim, ncol, nrow, 1, nodesperlayer, & - this%iout, 0, 0) + this%dis%ndim, ncol, nrow, 1, nodesperlayer, & + this%iout, 0, 0) ! ! -- multiply values by sfac do i = 1, nodesperlayer ta%taArray(i) = ta%taArray(i) * this%sfac - enddo + end do ! ! -- append the new time array to the list call AddTimeArrayToList(this%list, ta) @@ -425,8 +426,8 @@ logical function read_next_array(this) ! ! -- make sure block is closed call this%parser%terminateblock() - endif - endif + end if + end if return ! Normal return ! return @@ -434,7 +435,7 @@ end function read_next_array subroutine get_values_at_time(this, nvals, values, time) ! ****************************************************************************** -! get_values_at_time -- Return an array of values for a specified time, same +! get_values_at_time -- Return an array of values for a specified time, same ! units as time-series values. ! ****************************************************************************** ! @@ -448,44 +449,44 @@ subroutine get_values_at_time(this, nvals, values, time) ! -- local integer(I4B) :: i, ierr real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & - valdiff + valdiff type(TimeArrayType), pointer :: taEarlier => null() type(TimeArrayType), pointer :: taLater => null() ! formats - 10 format('Error getting array at time ',g10.3, & - ' for time-array series "',a,'"') +10 format('Error getting array at time ', g10.3, & + ' for time-array series "', a, '"') ! ------------------------------------------------------------------------------ ! ierr = 0 - call this%get_surrounding_records(time,taEarlier,taLater) + call this%get_surrounding_records(time, taEarlier, taLater) if (associated(taEarlier)) then if (associated(taLater)) then ! -- values are available for both earlier and later times if (this%iMethod == STEPWISE) then ! -- Just populate values from elements of earlier time array - values = taEarlier%taArray + values = taEarlier%taArray elseif (this%iMethod == LINEAR) then ! -- perform linear interpolation time0 = taEarlier%taTime time1 = taLater%tatime timediff = time1 - time0 timediffi = time - time0 - if (timediff>0) then - ratio = timediffi/timediff + if (timediff > 0) then + ratio = timediffi / timediff else ! -- should not happen if TS does not contain duplicate times ratio = 0.5d0 - endif + end if ! -- Iterate through all elements and perform interpolation. - do i=1,nvals + do i = 1, nvals val0 = taEarlier%taArray(i) val1 = taLater%taArray(i) valdiff = val1 - val0 - values(i) = val0 + (ratio*valdiff) - enddo + values(i) = val0 + (ratio * valdiff) + end do else ierr = 1 - endif + end if else if (is_same(taEarlier%taTime, time)) then values = taEarlier%taArray @@ -493,12 +494,12 @@ subroutine get_values_at_time(this, nvals, values, time) ! -- Only earlier time is available, and it is not time of interest; ! however, if method is STEPWISE, use value for earlier time. if (this%iMethod == STEPWISE) then - values = taEarlier%taArray + values = taEarlier%taArray else ierr = 1 - endif - endif - endif + end if + end if + end if else if (associated(taLater)) then if (is_same(taLater%taTime, time)) then @@ -506,26 +507,26 @@ subroutine get_values_at_time(this, nvals, values, time) else ! -- only later time is available, and it is not time of interest ierr = 1 - endif + end if else ! -- Neither earlier nor later time is available. ! This should never happen! ierr = 1 - endif - endif + end if + end if ! if (ierr > 0) then - write(errmsg,10)time,trim(this%Name) + write (errmsg, 10) time, trim(this%Name) call store_error(errmsg) call store_error_unit(this%inunit) - endif + end if ! return end subroutine get_values_at_time subroutine get_integrated_values(this, nvals, values, time0, time1) ! ****************************************************************************** -! get_integrated_values -- Populates an array with integrated values for a +! get_integrated_values -- Populates an array with integrated values for a ! specified time span. Units: (ts-value-unit)*time ! ****************************************************************************** ! @@ -533,14 +534,14 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals + integer(I4B), intent(in) :: nvals real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 ! -- local integer(I4B) :: i real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, & - t01, t1, timediff, value, value0, value1, valuediff + t01, t1, timediff, value, value0, value1, valuediff logical :: ldone type(ListNodeType), pointer :: precNode => null() type(ListNodeType), pointer :: currNode => null(), nextNode => null() @@ -548,8 +549,8 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) class(*), pointer :: currObj => null(), nextObj => null() ! -- formats 10 format('Error encountered while performing integration', & - ' for time-array series "',a,'" for time interval: ', & - g12.5,' to ',g12.5) + ' for time-array series "', a, '" for time interval: ', & + g12.5, ' to ', g12.5) ! ------------------------------------------------------------------------------ ! values = DZERO @@ -567,11 +568,11 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) if (.not. associated(currNode%nextNode)) then ! -- try to read the next array if (.not. this%read_next_array()) then - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call store_error_unit(this%inunit) - endif - endif + end if + end if if (associated(currNode%nextNode)) then nextNode => currNode%nextNode nextObj => nextNode%GetItem() @@ -583,26 +584,26 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) t0 = currTime else t0 = time0 - endif + end if if (nextTime <= time1) then t1 = nextTime else t1 = time1 - endif + end if ! -- For each element, find area of rectangle ! or trapezoid delimited by t0 and t1. t01 = t1 - t0 select case (this%iMethod) case (STEPWISE) - do i=1,nvals + do i = 1, nvals ! -- compute area of a rectangle value0 = currRecord%taArray(i) area = value0 * t01 ! -- add area to integrated value values(i) = values(i) + area - enddo + end do case (LINEAR) - do i=1,nvals + do i = 1, nvals ! -- compute area of a trapezoid timediff = nextTime - currTime ratio0 = (t0 - currTime) / timediff @@ -613,17 +614,17 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) area = 0.5d0 * t01 * (value0 + value1) ! -- add area to integrated value values(i) = values(i) + area - enddo + end do end select else - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call store_error('(Probable programming error)', terminate=.TRUE.) - endif + end if else ! Current node time = time1 so should be done ldone = .true. - endif + end if ! ! -- Are we done yet? if (t1 >= time1) then @@ -632,50 +633,50 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) if (.not. associated(currNode%nextNode)) then ! -- try to read the next array if (.not. this%read_next_array()) then - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - endif + end if + end if if (associated(currNode%nextNode)) then currNode => currNode%nextNode else - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call store_error('(Probable programming error)', terminate=.TRUE.) - endif - endif - enddo - endif + end if + end if + end do + end if ! if (this%autoDeallocate) then if (associated(precNode)) then - if (associated(precNode%prevNode))then + if (associated(precNode%prevNode)) then call this%DeallocateBackward(precNode%prevNode) - endif - endif - endif + end if + end if + end if ! return end subroutine get_integrated_values subroutine DeallocateBackward(this, fromNode) ! ****************************************************************************** -! DeallocateBackward -- Deallocate fromNode and all previous nodes in list; +! DeallocateBackward -- Deallocate fromNode and all previous nodes in list; ! reassign firstNode. ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this + class(TimeArraySeriesType), intent(inout) :: this type(ListNodeType), pointer, intent(inout) :: fromNode ! ! -- local - type(ListNodeType), pointer :: current => null() - type(ListNodeType), pointer :: prev => null() + type(ListNodeType), pointer :: current => null() + type(ListNodeType), pointer :: prev => null() type(TimeArrayType), pointer :: ta => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! if (associated(fromNode)) then @@ -684,7 +685,7 @@ subroutine DeallocateBackward(this, fromNode) this%list%firstNode => fromNode%nextNode else this%list%firstNode => null() - endif + end if ! -- deallocate fromNode and all previous nodes current => fromNode do while (associated(current)) @@ -696,41 +697,42 @@ subroutine DeallocateBackward(this, fromNode) call ta%da() call this%list%RemoveNode(current, .true.) current => prev - enddo + end do fromNode => null() - endif + end if ! return end subroutine DeallocateBackward subroutine get_latest_preceding_node(this, time, tslNode) ! ****************************************************************************** -! get_latest_preceding_node -- Return pointer to ListNodeType object for the +! get_latest_preceding_node -- Return pointer to ListNodeType object for the ! node representing the latest preceding time in the time series ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - real(DP), intent(in) :: time + class(TimeArraySeriesType), intent(inout) :: this + real(DP), intent(in) :: time type(ListNodeType), pointer, intent(inout) :: tslNode ! -- local real(DP) :: time0 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: node0 => null() + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: node0 => null() type(TimeArrayType), pointer :: ta => null() type(TimeArrayType), pointer :: ta0 => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tslNode => null() if (associated(this%list%firstNode)) then currNode => this%list%firstNode else - call store_error('probable programming error in get_latest_preceding_node', & + call store_error('probable programming error in & + &get_latest_preceding_node', & terminate=.TRUE.) - endif + end if ! continue ! -- If the next node is earlier than time of interest, advance along @@ -740,19 +742,19 @@ subroutine get_latest_preceding_node(this, time, tslNode) if (associated(currNode%nextNode)) then obj => currNode%nextNode%GetItem() ta => CastAsTimeArrayType(obj) - if (ta%taTime < time .or. is_same(ta%taTime, time)) then + if (ta%taTime < time .or. is_same(ta%taTime, time)) then currNode => currNode%nextNode else exit - endif + end if else ! -- read another record if (.not. this%read_next_array()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -769,9 +771,9 @@ subroutine get_latest_preceding_node(this, time, tslNode) time0 = ta0%taTime else exit - endif - enddo - endif + end if + end do + end if ! if (time0 <= time) tslNode => node0 ! @@ -794,30 +796,30 @@ subroutine tas_da(this) ! ! -- Deallocate contents of each time array in list n = this%list%Count() - do i=1,n + do i = 1, n ta => GetTimeArrayFromList(this%list, i) call ta%da() - enddo + end do ! ! -- Deallocate the list of time arrays call this%list%Clear(.true.) - deallocate(this%list) + deallocate (this%list) ! return end subroutine tas_da ! -- Procedures not type-bound - function CastAsTimeArraySeriesType(obj) result (res) + function CastAsTimeArraySeriesType(obj) result(res) ! ****************************************************************************** -! CastAsTimeArraySeriesType -- Cast an unlimited polymorphic object as +! CastAsTimeArraySeriesType -- Cast an unlimited polymorphic object as ! class(TimeArraySeriesType) ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(*), pointer, intent(inout) :: obj + class(*), pointer, intent(inout) :: obj type(TimeArraySeriesType), pointer :: res ! ------------------------------------------------------------------------------ ! @@ -832,7 +834,7 @@ function CastAsTimeArraySeriesType(obj) result (res) return end function CastAsTimeArraySeriesType - function GetTimeArraySeriesFromList(list, indx) result (res) + function GetTimeArraySeriesFromList(list, indx) result(res) ! ****************************************************************************** ! GetTimeArraySeriesFromList -- get time array from list ! ****************************************************************************** @@ -840,8 +842,8 @@ function GetTimeArraySeriesFromList(list, indx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer, intent(in) :: indx + type(ListType), intent(inout) :: list + integer, intent(in) :: indx type(TimeArraySeriesType), pointer :: res ! -- local class(*), pointer :: obj diff --git a/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 b/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 index add7e0852bf..4e1bb7d7a01 100644 --- a/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 @@ -1,9 +1,9 @@ module TimeArraySeriesLinkModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENPACKAGENAME, LENTIMESERIESTEXT - use InputOutputModule, only: UPCASE - use ListModule, only: ListType + use ConstantsModule, only: LENPACKAGENAME, LENTIMESERIESTEXT + use InputOutputModule, only: UPCASE + use ListModule, only: ListType use TimeArraySeriesModule, only: TimeArraySeriesType implicit none @@ -53,7 +53,7 @@ subroutine tasl_da(this) end subroutine tasl_da subroutine ConstructTimeArraySeriesLink(newTasLink, timeArraySeries, & - pkgName, bndArray, iprpak, text) + pkgName, bndArray, iprpak, text) ! ****************************************************************************** ! ConstructTimeArraySeriesLink -- construct ! ****************************************************************************** @@ -61,17 +61,17 @@ subroutine ConstructTimeArraySeriesLink(newTasLink, timeArraySeries, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(TimeArraySeriesLinkType), pointer, intent(out) :: newTasLink - type(TimeArraySeriesType), pointer, intent(in) :: timeArraySeries - character(len=*), intent(in) :: pkgName - real(DP), dimension(:), pointer, intent(in) :: bndArray - integer(I4B), intent(in) :: iprpak - character(len=*), intent(in) :: text + type(TimeArraySeriesLinkType), pointer, intent(out) :: newTasLink + type(TimeArraySeriesType), pointer, intent(in) :: timeArraySeries + character(len=*), intent(in) :: pkgName + real(DP), dimension(:), pointer, intent(in) :: bndArray + integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: text ! -- local character(len=LENPACKAGENAME) :: pkgNameTemp ! ------------------------------------------------------------------------------ ! - allocate(newTasLink) + allocate (newTasLink) ! Store package name as all caps pkgNameTemp = pkgName call UPCASE(pkgNameTemp) @@ -86,7 +86,7 @@ end subroutine ConstructTimeArraySeriesLink function CastAsTimeArraySeriesLinkType(obj) result(res) ! ****************************************************************************** -! CastAsTimeArraySeriesLinkType -- Cast an unlimited polymorphic object as +! CastAsTimeArraySeriesLinkType -- Cast an unlimited polymorphic object as ! TimeArraySeriesLinkType ! ****************************************************************************** ! @@ -115,7 +115,7 @@ subroutine AddTimeArraySeriesLinkToList(list, tasLink) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeArraySeriesLinkType), pointer, intent(inout) :: tasLink ! -- local class(*), pointer :: obj @@ -127,7 +127,7 @@ subroutine AddTimeArraySeriesLinkToList(list, tasLink) return end subroutine AddTimeArraySeriesLinkToList - function GetTimeArraySeriesLinkFromList(list, idx) result (res) + function GetTimeArraySeriesLinkFromList(list, idx) result(res) ! ****************************************************************************** ! GetTimeArraySeriesLinkFromList -- get from list ! ****************************************************************************** @@ -135,9 +135,9 @@ function GetTimeArraySeriesLinkFromList(list, idx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(TimeArraySeriesLinkType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + type(TimeArraySeriesLinkType), pointer :: res ! -- local class(*), pointer :: obj ! ------------------------------------------------------------------------------ diff --git a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 index ebd11739f1c..46040ca4cde 100644 --- a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 @@ -1,18 +1,18 @@ module TimeArraySeriesManagerModule - use KindModule, only: DP, I4B - use SimVariablesModule, only: errmsg - use ConstantsModule, only: DZERO, LENTIMESERIESNAME, LINELENGTH, & - LENHUGELINE - use ListModule, only: ListType - use SimModule, only: store_error, store_error_unit - use TdisModule, only: delt, totimc, kper, kstp + use KindModule, only: DP, I4B + use SimVariablesModule, only: errmsg + use ConstantsModule, only: DZERO, LENTIMESERIESNAME, LINELENGTH, & + LENHUGELINE + use ListModule, only: ListType + use SimModule, only: store_error, store_error_unit + use TdisModule, only: delt, totimc, kper, kstp use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType, & ConstructTimeArraySeriesLink, & GetTimeArraySeriesLinkFromList, & AddTimeArraySeriesLinkToList - use TimeArraySeriesModule, only: TimeArraySeriesType - use BaseDisModule, only: DisBaseType + use TimeArraySeriesModule, only: TimeArraySeriesType + use BaseDisModule, only: DisBaseType implicit none @@ -21,13 +21,13 @@ module TimeArraySeriesManagerModule type TimeArraySeriesManagerType ! -- Public members - integer(I4B), public :: iout = 0 ! output unit num - class(DisBaseType), pointer, public :: dis => null() ! pointer to dis + integer(I4B), public :: iout = 0 ! output unit num + class(DisBaseType), pointer, public :: dis => null() ! pointer to dis ! -- Private members - type(ListType), pointer, private :: boundTasLinks => null() ! list of TAS links - character(len=LINELENGTH), allocatable, dimension(:) :: tasfiles ! list of TA file names - type(TimeArraySeriesType), dimension(:), pointer, contiguous :: taslist ! array of TA pointers - character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: tasnames ! array of TA names + type(ListType), pointer, private :: boundTasLinks => null() ! list of TAS links + character(len=LINELENGTH), allocatable, dimension(:) :: tasfiles ! list of TA file names + type(TimeArraySeriesType), dimension(:), pointer, contiguous :: taslist ! array of TA pointers + character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: tasnames ! array of TA names contains ! -- Public procedures procedure, public :: tasmanager_df @@ -64,12 +64,12 @@ subroutine tasmanager_cr(this, dis, iout) ! this%iout = iout this%dis => dis - allocate(this%boundTasLinks) - allocate(this%tasfiles(0)) + allocate (this%boundTasLinks) + allocate (this%tasfiles(0)) ! return end subroutine tasmanager_cr - + subroutine tasmanager_df(this) ! ****************************************************************************** ! tasmanager_df -- define @@ -88,19 +88,19 @@ subroutine tasmanager_df(this) ! -- determine how many tasfiles. This is the number of time array series ! so allocate arrays to store them nfiles = size(this%tasfiles) - allocate(this%taslist(nfiles)) - allocate(this%tasnames(nfiles)) + allocate (this%taslist(nfiles)) + allocate (this%tasnames(nfiles)) ! ! -- Setup a time array series for each file specified do i = 1, nfiles tasptr => this%taslist(i) - call tasptr%tas_init(this%tasfiles(i), this%dis, & - this%iout, this%tasnames(i)) - enddo + call tasptr%tas_init(this%tasfiles(i), this%dis, & + this%iout, this%tasnames(i)) + end do ! return end subroutine tasmanager_df - + subroutine tasmgr_ad(this) ! ****************************************************************************** ! tasmgr_ad -- time step (or subtime step) advance. @@ -117,10 +117,11 @@ subroutine tasmgr_ad(this) integer(I4B) :: i, j, nlinks, nvals, isize1, isize2, inunit real(DP) :: begintime, endtime ! formats - character(len=*),parameter :: fmt5 = & - "(/,'Time-array-series controlled arrays in stress period ', & + character(len=*), parameter :: fmt5 = & + "(/,'Time-array-series controlled arrays in stress period ', & &i0, ', time step ', i0, ':')" -10 format('"',a, '" package: ',a,' array obtained from time-array series "',a,'"') +10 format('"', a, '" package: ', a, ' array obtained from time-array series "', & + a, '"') ! ------------------------------------------------------------------------------ ! ! -- Initialize time variables @@ -134,9 +135,9 @@ subroutine tasmgr_ad(this) nlinks = this%boundTasLinks%Count() do i = 1, nlinks tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - if (tasLink%Iprpak == 1 .and. i==1) then - write(this%iout, fmt5) kper, kstp - endif + if (tasLink%Iprpak == 1 .and. i == 1) then + write (this%iout, fmt5) kper, kstp + end if if (tasLink%UseDefaultProc) then timearrayseries => tasLink%timeArraySeries nvals = size(tasLink%BndArray) @@ -148,20 +149,20 @@ subroutine tasmgr_ad(this) ! -- If conversion from flux to flow is required, multiply by cell area if (tasLink%ConvertFlux) then call this%tasmgr_convert_flux(tasLink) - endif + end if ! ! -- If PRINT_INPUT is specified, write information ! regarding source of time-array series data if (tasLink%Iprpak == 1) then - write(this%iout,10) trim(tasLink%PackageName), & - trim(tasLink%Text), & - trim(tasLink%timeArraySeries%Name) - endif - endif + write (this%iout, 10) trim(tasLink%PackageName), & + trim(tasLink%Text), & + trim(tasLink%timeArraySeries%Name) + end if + end if if (i == nlinks) then - write(this%iout, '()') - endif - enddo + write (this%iout, '()') + end if + end do ! ! -- Now that all array values have been substituted, can now multiply ! an array by a multiplier array @@ -174,19 +175,19 @@ subroutine tasmgr_ad(this) if (isize1 == isize2 .and. isize1 == nvals) then do j = 1, nvals tasLink%BndArray(j) = tasLink%BndArray(j) * tasLink%RMultArray(j) - enddo + end do else - errmsg = 'Size mismatch between boundary and multiplier arrays' // & - ' using time-array series: ' // & + errmsg = 'Size mismatch between boundary and multiplier arrays'// & + ' using time-array series: '// & trim(tasLink%TimeArraySeries%Name) call store_error(errmsg) inunit = tasLink%TimeArraySeries%GetInunit() call store_error_unit(inunit) - endif - endif - endif - enddo - endif + end if + end if + end if + end do + end if ! return end subroutine tasmgr_ad @@ -208,10 +209,10 @@ subroutine tasmgr_da(this) ! -- Deallocate contents of each TimeArraySeriesType object in list ! of time-array series links. n = this%boundTasLinks%Count() - do i=1,n + do i = 1, n tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) call tasLink%da() - enddo + end do ! ! -- Go through and deallocate individual time array series do i = 1, size(this%taslist) @@ -220,12 +221,12 @@ subroutine tasmgr_da(this) ! ! -- Deallocate the list of time-array series links. call this%boundTasLinks%Clear(.true.) - deallocate(this%boundTasLinks) - deallocate(this%tasfiles) + deallocate (this%boundTasLinks) + deallocate (this%tasfiles) ! ! -- Deallocate the time array series - deallocate(this%taslist) - deallocate(this%tasnames) + deallocate (this%taslist) + deallocate (this%tasnames) ! ! -- nullify pointers this%dis => null() @@ -282,9 +283,9 @@ subroutine Reset(this, pkgName) if (associated(taslink)) then do j = 1, size(taslink%BndArray) taslink%BndArray(j) = DZERO - enddo - endif - enddo + end do + end if + end do ! ! -- Delete all existing time array links if (associated(this%boundTasLinks)) then @@ -295,14 +296,14 @@ subroutine Reset(this, pkgName) if (associated(taslink)) then call taslink%da() call this%boundTasLinks%RemoveNode(i, .true.) - endif - enddo - endif + end if + end do + end if ! return end subroutine Reset - subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & + subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & tasName, text, convertFlux, nodelist, inunit) ! ****************************************************************************** ! MakeTasLink -- Make link from TAS to package array @@ -324,7 +325,7 @@ subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & integer(I4B) :: i, nfiles, iloc character(LINELENGTH) :: ermsg type(TimeArraySeriesLinkType), pointer :: newTasLink - type(TimeArraySeriesType), pointer :: tasptr => null() + type(TimeArraySeriesType), pointer :: tasptr => null() ! ------------------------------------------------------------------------------ ! ! -- Find the time array series @@ -334,13 +335,13 @@ subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & if (this%tasnames(i) == tasname) then iloc = i exit - endif + end if end do if (iloc == 0) then - ermsg = 'Error: Time-array series "' // trim(tasName) // '" not found.' + ermsg = 'Error: Time-array series "'//trim(tasName)//'" not found.' call store_error(ermsg) call store_error_unit(inunit) - endif + end if tasptr => this%taslist(iloc) ! ! -- Construct a time-array series link @@ -375,7 +376,7 @@ function GetLink(this, indx) result(tasLink) ! if (associated(this%boundTasLinks)) then tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, indx) - endif + end if ! return end function GetLink @@ -397,7 +398,7 @@ function CountLinks(this) CountLinks = this%boundTasLinks%Count() else CountLinks = 0 - endif + end if ! return end function CountLinks @@ -421,13 +422,13 @@ subroutine tasmgr_convert_flux(this, tasLink) ! ------------------------------------------------------------------------------ ! n = size(tasLink%BndArray) - do i=1,n + do i = 1, n noder = tasLink%nodelist(i) if (noder > 0) then area = this%dis%get_area(noder) tasLink%BndArray(i) = tasLink%BndArray(i) * area - endif - enddo + end if + end do ! return end subroutine tasmgr_convert_flux @@ -440,7 +441,7 @@ subroutine tasmgr_add_link(this, tasLink) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeArraySeriesManagerType) :: this + class(TimeArraySeriesManagerType) :: this type(TimeArraySeriesLinkType), pointer :: tasLink ! -- local ! ------------------------------------------------------------------------------ diff --git a/src/Utilities/TimeSeries/TimeSeries.f90 b/src/Utilities/TimeSeries/TimeSeries.f90 index b6c687a84c6..f867607334b 100644 --- a/src/Utilities/TimeSeries/TimeSeries.f90 +++ b/src/Utilities/TimeSeries/TimeSeries.f90 @@ -1,16 +1,16 @@ module TimeSeriesModule use KindModule, only: DP, I4B - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & - LINEAREND, LENTIMESERIESNAME, LENHUGELINE, & - DZERO, DONE, DNODATA - use GenericUtilitiesModule, only: is_same - use InputOutputModule, only: GetUnit, openfile, ParseLine, upcase - use ListModule, only: ListType, ListNodeType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & + LINEAREND, LENTIMESERIESNAME, LENHUGELINE, & + DZERO, DONE, DNODATA + use GenericUtilitiesModule, only: is_same + use InputOutputModule, only: GetUnit, openfile, ParseLine, upcase + use ListModule, only: ListType, ListNodeType use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, & - store_error_unit + use SimModule, only: count_errors, store_error, & + store_error_unit use TimeSeriesRecordModule, only: TimeSeriesRecordType, & ConstructTimeSeriesRecord, & CastAsTimeSeriesRecordType, & @@ -63,7 +63,8 @@ module TimeSeriesModule integer(I4B), public :: nTimeSeries = 0 logical, public :: finishedReading = .false. character(len=LINELENGTH), public :: datafile = '' - type(TimeSeriesType), dimension(:), pointer, contiguous, public :: timeSeries => null() + type(TimeSeriesType), dimension(:), & + pointer, contiguous, public :: timeSeries => null() type(BlockParserType), pointer, public :: parser contains ! -- Public procedures @@ -95,14 +96,14 @@ subroutine ConstructTimeSeriesFile(newTimeSeriesFile) type(TimeSeriesFileType), pointer, intent(inout) :: newTimeSeriesFile ! ------------------------------------------------------------------------------ ! - allocate(newTimeSeriesFile) - allocate(newTimeSeriesFile%parser) + allocate (newTimeSeriesFile) + allocate (newTimeSeriesFile%parser) return end subroutine ConstructTimeSeriesFile function CastAsTimeSeriesFileType(obj) result(res) ! ****************************************************************************** -! CastAsTimeSeriesFileType -- Cast an unlimited polymorphic object as +! CastAsTimeSeriesFileType -- Cast an unlimited polymorphic object as ! class(TimeSeriesFileType) ! ****************************************************************************** ! @@ -126,7 +127,7 @@ end function CastAsTimeSeriesFileType function CastAsTimeSeriesFileClass(obj) result(res) ! ****************************************************************************** -! CastAsTimeSeriesFileClass -- Cast an unlimited polymorphic object as +! CastAsTimeSeriesFileClass -- Cast an unlimited polymorphic object as ! class(TimeSeriesFileType) ! ****************************************************************************** ! @@ -156,7 +157,7 @@ subroutine AddTimeSeriesFileToList(list, tsfile) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list class(TimeSeriesFileType), pointer, intent(inout) :: tsfile ! -- local class(*), pointer :: obj => null() @@ -168,7 +169,7 @@ subroutine AddTimeSeriesFileToList(list, tsfile) return end subroutine AddTimeSeriesFileToList - function GetTimeSeriesFileFromList(list, idx) result (res) + function GetTimeSeriesFileFromList(list, idx) result(res) ! ****************************************************************************** ! GetTimeSeriesFileFromList -- get from list ! ****************************************************************************** @@ -176,8 +177,8 @@ function GetTimeSeriesFileFromList(list, idx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx type(TimeSeriesFileType), pointer :: res ! -- local class(*), pointer :: obj => null() @@ -188,12 +189,12 @@ function GetTimeSeriesFileFromList(list, idx) result (res) ! if (.not. associated(res)) then res => CastAsTimeSeriesFileClass(obj) - endif + end if ! return end function GetTimeSeriesFileFromList - function SameTimeSeries(ts1, ts2) result (same) + function SameTimeSeries(ts1, ts2) result(same) ! ****************************************************************************** ! SameTimeSeries -- Compare two time series; if they are identical, return true. ! ****************************************************************************** @@ -217,12 +218,12 @@ function SameTimeSeries(ts1, ts2) result (same) call ts1%Reset() call ts2%Reset() ! - do i=1,n1 + do i = 1, n1 tsr1 => ts1%GetNextTimeSeriesRecord() tsr2 => ts2%GetNextTimeSeriesRecord() if (tsr1%tsrTime /= tsr2%tsrTime) return if (tsr1%tsrValue /= tsr2%tsrValue) return - enddo + end do ! same = .true. ! @@ -247,24 +248,24 @@ function GetValue(this, time0, time1, extendToEndOfSimulation) real(DP) :: GetValue ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 logical, intent(in), optional :: extendToEndOfSimulation ! logical :: extend ! ------------------------------------------------------------------------------ ! - if(present(extendToEndOfSimulation)) then + if (present(extendToEndOfSimulation)) then extend = extendToEndOfSimulation else extend = .false. - endif + end if ! select case (this%iMethod) case (STEPWISE, LINEAR) GetValue = this%get_average_value(time0, time1, extend) case (LINEAREND) - GetValue = this%get_value_at_time(time1, extend) + GetValue = this%get_value_at_time(time1, extend) end select ! return @@ -280,9 +281,9 @@ subroutine initialize_time_series(this, tsfile, name, autoDeallocate) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesType), intent(inout) :: this - class(TimeSeriesFileType), target :: tsfile - character(len=*), intent(in) :: name - logical, intent(in), optional :: autoDeallocate + class(TimeSeriesFileType), target :: tsfile + character(len=*), intent(in) :: name + logical, intent(in), optional :: autoDeallocate ! -- local character(len=LENTIMESERIESNAME) :: tsNameTemp ! ------------------------------------------------------------------------------ @@ -299,13 +300,13 @@ subroutine initialize_time_series(this, tsfile, name, autoDeallocate) if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate ! ! -- allocate the list - allocate(this%list) + allocate (this%list) ! ! -- ensure that NAME has been specified if (this%Name == '') then errmsg = 'Name not specified for time series.' call store_error(errmsg, terminate=.TRUE.) - endif + end if ! return end subroutine initialize_time_series @@ -319,7 +320,7 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time + real(DP), intent(in) :: time type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecEarlier type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecLater ! -- local @@ -329,7 +330,7 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) type(ListNodeType), pointer :: tsNode1 => null() type(TimeSeriesRecordType), pointer :: tsr => null(), tsrec0 => null() type(TimeSeriesRecordType), pointer :: tsrec1 => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tsrecEarlier => null() @@ -337,7 +338,7 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) ! if (associated(this%list%firstNode)) then currNode => this%list%firstNode - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -350,15 +351,15 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) currNode => currNode%nextNode else exit - endif + end if else ! -- read another record if (.not. this%read_next_record()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -375,8 +376,8 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) time0 = tsrec0%tsrTime else exit - endif - enddo + end if + end do ! ! -- find later record tsNode1 => currNode @@ -394,11 +395,11 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) if (.not. this%read_next_record()) then ! -- end of file reached, so exit loop exit - endif - endif - enddo + end if + end if + end do ! - endif + end if ! if (time0 < time .or. is_same(time0, time)) tsrecEarlier => tsrec0 if (time1 > time .or. is_same(time1, time)) tsrecLater => tsrec1 @@ -416,8 +417,8 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time type(ListNodeType), pointer, intent(inout) :: nodeEarlier type(ListNodeType), pointer, intent(inout) :: nodeLater ! -- local @@ -429,17 +430,17 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) type(TimeSeriesRecordType), pointer :: tsrec1 => null() type(TimeSeriesRecordType), pointer :: tsrecEarlier type(TimeSeriesRecordType), pointer :: tsrecLater - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tsrecEarlier => null() tsrecLater => null() nodeEarlier => null() - nodeLater => null() + nodeLater => null() ! if (associated(this%list%firstNode)) then currNode => this%list%firstNode - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -452,14 +453,14 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) currNode => currNode%nextNode else exit - endif + end if else exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -476,8 +477,8 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) time0 = tsrec0%tsrTime else exit - endif - enddo + end if + end do ! ! -- find later record tsNode1 => currNode @@ -492,19 +493,19 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) time1 = tsrec1%tsrTime else exit - endif - enddo + end if + end do ! - endif + end if ! if (time0 < time .or. is_same(time0, time)) then tsrecEarlier => tsrec0 nodeEarlier => tsNode0 - endif + end if if (time1 > time .or. is_same(time1, time)) then tsrecLater => tsrec1 nodeLater => tsNode1 - endif + end if ! return end subroutine get_surrounding_nodes @@ -526,12 +527,12 @@ logical function read_next_record(this) if (this%tsfile%finishedReading) then read_next_record = .false. return - endif + end if ! read_next_record = this%tsfile%read_tsfile_line() if (.not. read_next_record) then this%tsfile%finishedReading = .true. - endif + end if return ! end function read_next_record @@ -548,25 +549,25 @@ function get_value_at_time(this, time, extendToEndOfSimulation) real(DP) :: get_value_at_time ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time ! time of interest + real(DP), intent(in) :: time ! time of interest logical, intent(in) :: extendToEndOfSimulation ! -- local integer(I4B) :: ierr real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & - valdiff + valdiff type(TimeSeriesRecordType), pointer :: tsrEarlier => null() type(TimeSeriesRecordType), pointer :: tsrLater => null() ! -- formats - 10 format('Error getting value at time ',g10.3,' for time series "',a,'"') +10 format('Error getting value at time ', g10.3, ' for time series "', a, '"') ! ------------------------------------------------------------------------------ ! ierr = 0 - call this%get_surrounding_records(time,tsrEarlier,tsrLater) + call this%get_surrounding_records(time, tsrEarlier, tsrLater) if (associated(tsrEarlier)) then if (associated(tsrLater)) then ! -- values are available for both earlier and later times if (this%iMethod == STEPWISE) then - get_value_at_time = tsrEarlier%tsrValue + get_value_at_time = tsrEarlier%tsrValue elseif (this%iMethod == LINEAR .or. this%iMethod == LINEAREND) then ! -- For get_value_at_time, result is the same for either ! linear method. @@ -575,19 +576,19 @@ function get_value_at_time(this, time, extendToEndOfSimulation) time1 = tsrLater%tsrtime timediff = time1 - time0 timediffi = time - time0 - if (timediff>0) then - ratio = timediffi/timediff + if (timediff > 0) then + ratio = timediffi / timediff else ! -- should not happen if TS does not contain duplicate times ratio = 0.5d0 - endif + end if val0 = tsrEarlier%tsrValue val1 = tsrLater%tsrValue valdiff = val1 - val0 - get_value_at_time = val0 + (ratio*valdiff) + get_value_at_time = val0 + (ratio * valdiff) else ierr = 1 - endif + end if else if (extendToEndOfSimulation .or. is_same(tsrEarlier%tsrTime, time)) then get_value_at_time = tsrEarlier%tsrValue @@ -595,12 +596,12 @@ function get_value_at_time(this, time, extendToEndOfSimulation) ! -- Only earlier time is available, and it is not time of interest; ! however, if method is STEPWISE, use value for earlier time. if (this%iMethod == STEPWISE) then - get_value_at_time = tsrEarlier%tsrValue + get_value_at_time = tsrEarlier%tsrValue else ierr = 1 - endif - endif - endif + end if + end if + end if else if (associated(tsrLater)) then if (is_same(tsrLater%tsrTime, time)) then @@ -608,18 +609,18 @@ function get_value_at_time(this, time, extendToEndOfSimulation) else ! -- only later time is available, and it is not time of interest ierr = 1 - endif + end if else ! -- Neither earlier nor later time is available. ! This should never happen! ierr = 1 - endif - endif + end if + end if ! if (ierr > 0) then - write(errmsg,10) time, trim(this%Name) + write (errmsg, 10) time, trim(this%Name) call store_error(errmsg, terminate=.TRUE.) - endif + end if ! return end function get_value_at_time @@ -637,12 +638,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) real(DP) :: get_integrated_value ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 logical, intent(in) :: extendToEndOfSimulation ! -- local real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, t01, t1, & - timediff, value, value0, value1, valuediff, currVal, nextVal + timediff, value, value0, value1, valuediff, currVal, nextVal logical :: ldone, lprocess type(ListNodeType), pointer :: tslNodePreceding => null() type(ListNodeType), pointer :: currNode => null(), nextNode => null() @@ -650,8 +651,8 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) type(TimeSeriesRecordType), pointer :: nextRecord => null() class(*), pointer :: currObj => null(), nextObj => null() ! -- formats - 10 format('Error encountered while performing integration', & - ' for time series "',a,'" for time interval: ',g12.5,' to ',g12.5) +10 format('Error encountered while performing integration', & + ' for time series "', a, '" for time interval: ', g12.5, ' to ', g12.5) ! ------------------------------------------------------------------------------ ! value = DZERO @@ -671,12 +672,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) if (.not. associated(currNode%nextNode)) then ! -- try to read the next record if (.not. this%read_next_record()) then - if(.not. extendToEndOfSimulation) then - write(errmsg,10)trim(this%Name),time0,time1 + if (.not. extendToEndOfSimulation) then + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg, terminate=.TRUE.) - endif - endif - endif + end if + end if + end if ! currVal = currRecord%tsrValue lprocess = .false. @@ -692,7 +693,7 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) nextTime = time1 nextVal = currVal lprocess = .true. - endif + end if ! if (lprocess) then ! -- determine lower and upper limits of time span of interest @@ -701,12 +702,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) t0 = currTime else t0 = time0 - endif + end if if (nextTime < time1 .or. is_same(nextTime, time1)) then t1 = nextTime else t1 = time1 - endif + end if ! -- find area of rectangle or trapezoid delimited by t0 and t1 t01 = t1 - t0 select case (this%iMethod) @@ -727,12 +728,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) elseif (this%iMethod == LINEAREND) then area = DZERO value = value1 - endif + end if end select ! -- add area to integrated value value = value + area - endif - endif + end if + end if ! ! -- Are we done yet? if (t1 > time1) then @@ -744,24 +745,24 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) if (.not. associated(currNode%nextNode)) then ! -- Not done and no more data, so try to read the next record if (.not. this%read_next_record()) then - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg, terminate=.TRUE.) - endif + end if elseif (associated(currNode%nextNode)) then currNode => currNode%nextNode - endif - endif - enddo - endif + end if + end if + end do + end if ! get_integrated_value = value if (this%autoDeallocate) then if (associated(tslNodePreceding)) then - if (associated(tslNodePreceding%prevNode))then + if (associated(tslNodePreceding%prevNode)) then call this%list%DeallocateBackward(tslNodePreceding%prevNode) - endif - endif - endif + end if + end if + end if return end function get_integrated_value @@ -778,8 +779,8 @@ function get_average_value(this, time0, time1, extendToEndOfSimulation) real(DP) :: get_average_value ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 logical, intent(in) :: extendToEndOfSimulation ! -- local real(DP) :: timediff, value, valueIntegrated @@ -787,16 +788,17 @@ function get_average_value(this, time0, time1, extendToEndOfSimulation) ! timediff = time1 - time0 if (timediff > 0) then - valueIntegrated = this%get_integrated_value(time0, time1, extendToEndOfSimulation) + valueIntegrated = this%get_integrated_value(time0, time1, & + extendToEndOfSimulation) if (this%iMethod == LINEAREND) then value = valueIntegrated else value = valueIntegrated / timediff - endif + end if else ! -- time0 and time1 are the same value = this%get_value_at_time(time0, extendToEndOfSimulation) - endif + end if get_average_value = value ! return @@ -812,8 +814,8 @@ subroutine get_latest_preceding_node(this, time, tslNode) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time type(ListNodeType), pointer, intent(inout) :: tslNode ! -- local real(DP) :: time0 @@ -821,16 +823,17 @@ subroutine get_latest_preceding_node(this, time, tslNode) type(ListNodeType), pointer :: tsNode0 => null() type(TimeSeriesRecordType), pointer :: tsr => null() type(TimeSeriesRecordType), pointer :: tsrec0 => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tslNode => null() if (associated(this%list%firstNode)) then currNode => this%list%firstNode else - call store_error('probable programming error in get_latest_preceding_node', & + call store_error('probable programming error in & + &get_latest_preceding_node', & terminate=.TRUE.) - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -843,15 +846,15 @@ subroutine get_latest_preceding_node(this, time, tslNode) currNode => currNode%nextNode else exit - endif + end if else ! -- read another record if (.not. this%read_next_record()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -868,9 +871,9 @@ subroutine get_latest_preceding_node(this, time, tslNode) time0 = tsrec0%tsrTime else exit - endif - enddo - endif + end if + end do + end if ! if (time0 < time .or. is_same(time0, time)) tslNode => tsNode0 ! @@ -890,8 +893,8 @@ subroutine ts_da(this) ! if (associated(this%list)) then call this%list%Clear(.true.) - deallocate(this%list) - endif + deallocate (this%list) + end if ! return end subroutine ts_da @@ -916,7 +919,7 @@ subroutine AddTimeSeriesRecord(this, tsr) return end subroutine AddTimeSeriesRecord - function GetCurrentTimeSeriesRecord(this) result (res) + function GetCurrentTimeSeriesRecord(this) result(res) ! ****************************************************************************** ! GetCurrentTimeSeriesRecord -- get current ts record ! ****************************************************************************** @@ -936,12 +939,12 @@ function GetCurrentTimeSeriesRecord(this) result (res) obj => this%list%GetItem() if (associated(obj)) then res => CastAsTimeSeriesRecordType(obj) - endif + end if ! return end function GetCurrentTimeSeriesRecord - function GetPreviousTimeSeriesRecord(this) result (res) + function GetPreviousTimeSeriesRecord(this) result(res) ! ****************************************************************************** ! GetPreviousTimeSeriesRecord -- get previous ts record ! ****************************************************************************** @@ -961,12 +964,12 @@ function GetPreviousTimeSeriesRecord(this) result (res) obj => this%list%GetPreviousItem() if (associated(obj)) then res => CastAsTimeSeriesRecordType(obj) - endif + end if ! return end function GetPreviousTimeSeriesRecord - function GetNextTimeSeriesRecord(this) result (res) + function GetNextTimeSeriesRecord(this) result(res) ! ****************************************************************************** ! GetNextTimeSeriesRecord -- get next ts record ! ****************************************************************************** @@ -986,12 +989,12 @@ function GetNextTimeSeriesRecord(this) result (res) obj => this%list%GetNextItem() if (associated(obj)) then res => CastAsTimeSeriesRecordType(obj) - endif + end if ! return end function GetNextTimeSeriesRecord - function GetTimeSeriesRecord(this, time, epsi) result (res) + function GetTimeSeriesRecord(this, time, epsi) result(res) ! ****************************************************************************** ! GetTimeSeriesRecord -- get ts record ! ****************************************************************************** @@ -1016,12 +1019,12 @@ function GetTimeSeriesRecord(this, time, epsi) result (res) if (is_same(tsr%tsrTime, time)) then res => tsr exit - endif + end if if (tsr%tsrTime > time) exit else exit - endif - enddo + end if + end do ! return end function GetTimeSeriesRecord @@ -1050,7 +1053,7 @@ subroutine InsertTsr(this, tsr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesType), intent(inout) :: this + class(TimeSeriesType), intent(inout) :: this type(TimeSeriesRecordType), pointer, intent(inout) :: tsr ! -- local double precision :: badtime, time, time0, time1 @@ -1070,16 +1073,16 @@ subroutine InsertTsr(this, tsr) tsrEarlier => CastAsTimeSeriesRecordType(obj) if (associated(tsrEarlier)) then time0 = tsrEarlier%tsrTime - endif - endif + end if + end if ! if (associated(nodeLater)) then obj => nodeLater%GetItem() tsrLater => CastAsTimeSeriesRecordType(obj) if (associated(tsrLater)) then time1 = tsrLater%tsrTime - endif - endif + end if + end if ! if (time0 > badtime) then ! Time0 is valid @@ -1093,17 +1096,17 @@ subroutine InsertTsr(this, tsr) ! No need to insert a time series record, but if existing record ! for time of interest has NODATA as tsrValue, replace tsrValue if (time == time0 .and. tsrEarlier%tsrValue == DNODATA .and. & - tsr%tsrValue /= DNODATA) then + tsr%tsrValue /= DNODATA) then tsrEarlier%tsrValue = tsr%tsrValue elseif (time == time1 .and. tsrLater%tsrValue == DNODATA .and. & tsr%tsrValue /= DNODATA) then tsrLater%tsrValue = tsr%tsrValue - endif - endif + end if + end if else ! Time0 is valid and time1 is invalid. Just add tsr to the list. call this%AddTimeSeriesRecord(tsr) - endif + end if else ! Time0 is invalid, so time1 must be for first node in list if (time1 > badtime) then @@ -1117,18 +1120,18 @@ subroutine InsertTsr(this, tsr) ! for time of interest has NODATA as tsrValue, replace tsrValue if (tsrLater%tsrValue == DNODATA .and. tsr%tsrValue /= DNODATA) then tsrLater%tsrValue = tsr%tsrValue - endif - endif + end if + end if else ! Both time0 and time1 are invalid. Just add tsr to the list. call this%AddTimeSeriesRecord(tsr) - endif - endif + end if + end if ! return end subroutine InsertTsr - function FindLatestTime(this, readToEnd) result (endtime) + function FindLatestTime(this, readToEnd) result(endtime) ! ****************************************************************************** ! FindLatestTime -- find latest time ! ****************************************************************************** @@ -1149,9 +1152,9 @@ function FindLatestTime(this, readToEnd) result (endtime) if (present(readToEnd)) then if (readToEnd) then do while (this%read_next_record()) - enddo - endif - endif + end do + end if + end if ! nrecords = this%list%Count() obj => this%list%GetItem(nrecords) @@ -1170,7 +1173,7 @@ subroutine Clear(this, destroy) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesType), intent(inout) :: this - logical, optional, intent(in) :: destroy + logical, optional, intent(in) :: destroy ! ------------------------------------------------------------------------------ ! call this%list%Clear(destroy) @@ -1197,11 +1200,11 @@ function Count(this) Count = size(this%timeSeries) else Count = 0 - endif + end if return end function Count - function GetTimeSeries(this, indx) result (res) + function GetTimeSeries(this, indx) result(res) ! ****************************************************************************** ! GetTimeSeries -- get ts ! ****************************************************************************** @@ -1218,13 +1221,13 @@ function GetTimeSeries(this, indx) result (res) res => null() if (indx > 0 .and. indx <= this%nTimeSeries) then res => this%timeSeries(indx) - endif + end if return end function GetTimeSeries subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ****************************************************************************** -! Initializetsfile -- Open time-series tsfile file and read options and first +! Initializetsfile -- Open time-series tsfile file and read options and first ! record, which may contain data to define multiple time series. ! ****************************************************************************** ! @@ -1232,9 +1235,9 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesFileType), target, intent(inout) :: this - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: autoDeallocate + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: autoDeallocate ! -- local integer(I4B) :: iMethod, istatus, j, nwords integer(I4B) :: ierr, inunit @@ -1257,7 +1260,7 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! -- Open the time-series tsfile input file this%inunit = GetUnit() inunit = this%inunit - call openfile(inunit,0,filename,'TS6') + call openfile(inunit, 0, filename, 'TS6') ! ! -- Initialize block parser call this%parser%Initialize(this%inunit, this%iout) @@ -1268,20 +1271,20 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ! -- get BEGIN line of ATTRIBUTES block call this%parser%GetBlock('ATTRIBUTES', found, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (ierr /= 0) then ! end of file - errmsg = 'End-of-file encountered while searching for' // & - ' ATTRIBUTES in time-series ' // & - 'input file "' // trim(this%datafile) // '"' + errmsg = 'End-of-file encountered while searching for'// & + ' ATTRIBUTES in time-series '// & + 'input file "'//trim(this%datafile)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() elseif (.not. found) then - errmsg = 'ATTRIBUTES block not found in time-series ' // & - 'tsfile input file "' // trim(this%datafile) // '"' + errmsg = 'ATTRIBUTES block not found in time-series '// & + 'tsfile input file "'//trim(this%datafile)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- parse ATTRIBUTES entries do @@ -1293,12 +1296,13 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) call this%parser%GetStringCaps(keyword) ! ! support either NAME or NAMES as equivalent keywords - if (keyword=='NAMES') keyword = 'NAME' + if (keyword == 'NAMES') keyword = 'NAME' ! - if (keyword /= 'NAME' .and. keyword /= 'METHODS' .and. keyword /= 'SFACS') then + if (keyword /= 'NAME' .and. keyword /= 'METHODS' .and. & + keyword /= 'SFACS') then ! -- get the word following the keyword (the key value) call this%parser%GetStringCaps(keyvalue) - endif + end if ! select case (keyword) case ('NAME') @@ -1308,18 +1312,18 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) this%nTimeSeries = nwords ! -- Allocate the timeSeries array and initialize each ! time series. - allocate(this%timeSeries(this%nTimeSeries)) - do j=1,this%nTimeSeries + allocate (this%timeSeries(this%nTimeSeries)) + do j = 1, this%nTimeSeries call this%timeSeries(j)%initialize_time_series(this, words(j), & - autoDeallocateLocal) - enddo + autoDeallocateLocal) + end do case ('METHOD') if (this%nTimeSeries == 0) then errmsg = 'Error: NAME attribute not provided before METHOD in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if select case (keyvalue) case ('STEPWISE') iMethod = STEPWISE @@ -1328,28 +1332,28 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) case ('LINEAREND') iMethod = LINEAREND case default - errmsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' + errmsg = 'Unknown interpolation method: "'//trim(keyvalue)//'"' call store_error(errmsg) end select - do j=1,this%nTimeSeries + do j = 1, this%nTimeSeries this%timeSeries(j)%iMethod = iMethod - enddo + end do case ('METHODS') if (this%nTimeSeries == 0) then errmsg = 'Error: NAME attribute not provided before METHODS in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetRemainingLine(line) call ParseLine(line, nwords, words, this%parser%iuactive) if (nwords < this%nTimeSeries) then - errmsg = 'METHODS attribute does not list a method for' // & - ' all time series.' + errmsg = 'METHODS attribute does not list a method for'// & + ' all time series.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - do j=1,this%nTimeSeries + end if + do j = 1, this%nTimeSeries call upcase(words(j)) select case (words(j)) case ('STEPWISE') @@ -1359,48 +1363,48 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) case ('LINEAREND') iMethod = LINEAREND case default - errmsg = 'Unknown interpolation method: "' // trim(words(j)) // '"' + errmsg = 'Unknown interpolation method: "'//trim(words(j))//'"' call store_error(errmsg) end select this%timeSeries(j)%iMethod = iMethod - enddo + end do case ('SFAC') if (this%nTimeSeries == 0) then errmsg = 'NAME attribute not provided before SFAC in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - read(keyvalue,*,iostat=istatus)sfaclocal + end if + read (keyvalue, *, iostat=istatus) sfaclocal if (istatus /= 0) then - errmsg = 'Error reading numeric value from: "' // trim(keyvalue) // '"' + errmsg = 'Error reading numeric value from: "'//trim(keyvalue)//'"' call store_error(errmsg) - endif - do j=1,this%nTimeSeries + end if + do j = 1, this%nTimeSeries this%timeSeries(j)%sfac = sfaclocal - enddo + end do case ('SFACS') if (this%nTimeSeries == 0) then errmsg = 'NAME attribute not provided before SFACS in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - do j=1,this%nTimeSeries + end if + do j = 1, this%nTimeSeries sfaclocal = this%parser%GetDouble() this%timeSeries(j)%sfac = sfaclocal - enddo + end do case ('AUTODEALLOCATE') - do j=1,this%nTimeSeries + do j = 1, this%nTimeSeries this%timeSeries(j)%autoDeallocate = (keyvalue == 'TRUE') - enddo + end do case default - errmsg = 'Unknown option found in ATTRIBUTES block: "' // & - trim(keyword) // '"' + errmsg = 'Unknown option found in ATTRIBUTES block: "'// & + trim(keyword)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() end select - enddo + end do ! ! -- Get TIMESERIES block call this%parser%GetBlock('TIMESERIES', found, ierr, & @@ -1408,17 +1412,17 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ! -- Read the first line of time-series data if (.not. this%read_tsfile_line()) then - errmsg = 'Error: No time-series data contained in file: ' // & - trim(this%datafile) + errmsg = 'Error: No time-series data contained in file: '// & + trim(this%datafile) call store_error(errmsg) - endif + end if ! ! -- Clean up and return - if (allocated(words)) deallocate(words) + if (allocated(words)) deallocate (words) ! if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! return end subroutine Initializetsfile @@ -1448,20 +1452,20 @@ logical function read_tsfile_line(this) ! -- Check if we've reached the end of the TIMESERIES block if (endOfBlock) then return - endif + end if ! ! -- Get the time tsrTime = this%parser%GetDouble() ! ! -- Construct a new record and append a new node to each time series - tsloop: do i=1,this%nTimeSeries + tsloop: do i = 1, this%nTimeSeries tsrValue = this%parser%GetDouble() if (tsrValue == DNODATA) cycle tsloop ! -- multiply value by sfac tsrValue = tsrValue * this%timeSeries(i)%sfac call ConstructTimeSeriesRecord(tsRecord, tsrTime, tsrValue) call AddTimeSeriesRecordToList(this%timeSeries(i)%list, tsRecord) - enddo tsloop + end do tsloop read_tsfile_line = .true. ! return @@ -1482,16 +1486,16 @@ subroutine tsf_da(this) ! ------------------------------------------------------------------------------ ! n = this%Count() - do i=1,n + do i = 1, n ts => this%GetTimeSeries(i) if (associated(ts)) then call ts%da() ! deallocate(ts) - endif - enddo + end if + end do ! - deallocate(this%timeSeries) - deallocate(this%parser) + deallocate (this%timeSeries) + deallocate (this%parser) ! return end subroutine tsf_da diff --git a/src/Utilities/TimeSeries/TimeSeriesFileList.f90 b/src/Utilities/TimeSeries/TimeSeriesFileList.f90 index 06bcfd1e8ef..f0dbd3a8f42 100644 --- a/src/Utilities/TimeSeries/TimeSeriesFileList.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesFileList.f90 @@ -1,8 +1,8 @@ module TimeSeriesFileListModule use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH - use ListModule, only: ListType + use ConstantsModule, only: LINELENGTH + use ListModule, only: ListType use TimeSeriesModule, only: TimeSeriesFileType, & ConstructTimeSeriesFile, & GetTimeSeriesFileFromList, & @@ -19,13 +19,13 @@ module TimeSeriesFileListModule type(ListType), public :: tsfileList contains ! -- Public procedures - procedure, public :: Add - procedure, public :: Counttsfiles - procedure, public :: CountTimeSeries - procedure, public :: Gettsfile - procedure, public :: Clear - procedure, public :: da => tsfl_da - procedure, public :: add_time_series_tsfile + procedure, public :: Add + procedure, public :: Counttsfiles + procedure, public :: CountTimeSeries + procedure, public :: Gettsfile + procedure, public :: Clear + procedure, public :: da => tsfl_da + procedure, public :: add_time_series_tsfile end type TimeSeriesFileListType contains @@ -87,17 +87,17 @@ function CountTimeSeries(this) ! numtsfiles = this%Counttsfiles() CountTimeSeries = 0 - do i=1,numtsfiles + do i = 1, numtsfiles tsfile => this%Gettsfile(i) if (associated(tsfile)) then CountTimeSeries = CountTimeSeries + tsfile%Count() - endif - enddo + end if + end do ! return end function CountTimeSeries - function Gettsfile(this, indx) result (res) + function Gettsfile(this, indx) result(res) implicit none ! -- dummy class(TimeSeriesFileListType) :: this @@ -115,7 +115,7 @@ end function Gettsfile subroutine add_time_series_tsfile(this, tsfile) implicit none ! -- dummy - class(TimeSeriesFileListType), intent(inout) :: this + class(TimeSeriesFileListType), intent(inout) :: this class(TimeSeriesFileType), pointer, intent(inout) :: tsfile ! -- local ! @@ -132,10 +132,10 @@ subroutine tsfl_da(this) type(TimeSeriesFileType), pointer :: tsf => null() ! n = this%Counttsfiles() - do i=1,n + do i = 1, n tsf => this%Gettsfile(i) call tsf%da() - enddo + end do ! call this%tsfileList%Clear(.true.) ! diff --git a/src/Utilities/TimeSeries/TimeSeriesLink.f90 b/src/Utilities/TimeSeries/TimeSeriesLink.f90 index f755903306f..6379be6daf6 100644 --- a/src/Utilities/TimeSeries/TimeSeriesLink.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesLink.f90 @@ -1,23 +1,23 @@ module TimeSeriesLinkModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENBOUNDNAME, LENPACKAGENAME, & - LENTIMESERIESTEXT + use ConstantsModule, only: DZERO, LENBOUNDNAME, LENPACKAGENAME, & + LENTIMESERIESTEXT use InputOutputModule, only: UPCASE - use ListModule, only: ListType - use TimeSeriesModule, only: TimeSeriesType + use ListModule, only: ListType + use TimeSeriesModule, only: TimeSeriesType implicit none private - public :: TimeSeriesLinkType, ConstructTimeSeriesLink, & + public :: TimeSeriesLinkType, ConstructTimeSeriesLink, & GetTimeSeriesLinkFromList, AddTimeSeriesLinkToList private :: CastAsTimeSeriesLinkType type :: TimeSeriesLinkType ! -- Public members - integer(I4B), public :: IRow = 0 ! row index (2nd dim) in bound or auxval array - integer(I4B), public :: JCol = 0 ! column index (1st dim) in bound or auxval array + integer(I4B), public :: IRow = 0 ! row index (2nd dim) in bound or auxval array + integer(I4B), public :: JCol = 0 ! column index (1st dim) in bound or auxval array integer(I4B), public :: Iprpak = 1 ! BndElement can point to an element in either the bound or auxval ! array of BndType, or any other double precision variable or array @@ -53,7 +53,7 @@ subroutine ConstructTimeSeriesLink(newTsLink, timeSeries, pkgName, & ! -- local character(len=LENPACKAGENAME) :: pkgNameTemp ! - allocate(newTsLink) + allocate (newTsLink) ! ! Store package name as all caps pkgNameTemp = pkgName @@ -68,7 +68,7 @@ subroutine ConstructTimeSeriesLink(newTsLink, timeSeries, pkgName, & ! if (present(text)) then newTsLink%Text = text - endif + end if ! return end subroutine ConstructTimeSeriesLink @@ -110,7 +110,7 @@ end function GetTimeSeriesLinkFromList subroutine AddTimeSeriesLinkToList(list, tslink) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeSeriesLinkType), pointer, intent(inout) :: tslink ! -- local class(*), pointer :: obj diff --git a/src/Utilities/TimeSeries/TimeSeriesManager.f90 b/src/Utilities/TimeSeries/TimeSeriesManager.f90 index 065831a4bf3..157564a863f 100644 --- a/src/Utilities/TimeSeries/TimeSeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesManager.f90 @@ -1,43 +1,43 @@ module TimeSeriesManagerModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENPACKAGENAME, MAXCHARLEN, & - LINELENGTH, LENTIMESERIESNAME - use HashTableModule, only: HashTableType, hash_table_cr, & - hash_table_da - use InputOutputModule, only: same_word, UPCASE - use ListModule, only: ListType - use SimModule, only: store_error, store_error_unit - use TdisModule, only: delt, kper, kstp, totim, totimc, & - totimsav - use TimeSeriesFileListModule, only: TimeSeriesFileListType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - ConstructTimeSeriesLink, & - GetTimeSeriesLinkFromList, & - AddTimeSeriesLinkToList - use TimeSeriesModule, only: TimeSeriesContainerType, & - TimeSeriesFileType, & - TimeSeriesType + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENPACKAGENAME, MAXCHARLEN, & + LINELENGTH, LENTIMESERIESNAME + use HashTableModule, only: HashTableType, hash_table_cr, & + hash_table_da + use InputOutputModule, only: same_word, UPCASE + use ListModule, only: ListType + use SimModule, only: store_error, store_error_unit + use TdisModule, only: delt, kper, kstp, totim, totimc, & + totimsav + use TimeSeriesFileListModule, only: TimeSeriesFileListType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + ConstructTimeSeriesLink, & + GetTimeSeriesLinkFromList, & + AddTimeSeriesLinkToList + use TimeSeriesModule, only: TimeSeriesContainerType, & + TimeSeriesFileType, & + TimeSeriesType implicit none private - public :: TimeSeriesManagerType, read_value_or_time_series, & - read_value_or_time_series_adv, & + public :: TimeSeriesManagerType, read_value_or_time_series, & + read_value_or_time_series_adv, & var_timeseries, tsmanager_cr type TimeSeriesManagerType - integer(I4B), public :: iout = 0 ! output unit number - type(TimeSeriesFileListType), pointer, public :: tsfileList => null() ! list of ts files objs - type(ListType), pointer, public :: boundTsLinks => null() ! links to bound and aux - integer(I4B) :: numtsfiles = 0 ! number of ts files - character(len=MAXCHARLEN), allocatable, dimension(:) :: tsfiles ! list of ts files - logical, private :: removeTsLinksOnCompletion = .false. ! flag indicating whether time series links should be removed in ad() once simulation time passes the end of the time series - logical, private :: extendTsToEndOfSimulation = .false. ! flag indicating whether time series should be extended to provide their final value for all times after the series end time - type(ListType), pointer, private :: auxvarTsLinks => null() ! list of aux links - type(HashTableType), pointer, private :: BndTsHashTable => null() ! hash of ts to tsobj - type(TimeSeriesContainerType), allocatable, dimension(:), & - private :: TsContainers + integer(I4B), public :: iout = 0 ! output unit number + type(TimeSeriesFileListType), pointer, public :: tsfileList => null() ! list of ts files objs + type(ListType), pointer, public :: boundTsLinks => null() ! links to bound and aux + integer(I4B) :: numtsfiles = 0 ! number of ts files + character(len=MAXCHARLEN), allocatable, dimension(:) :: tsfiles ! list of ts files + logical, private :: removeTsLinksOnCompletion = .false. ! flag indicating whether time series links should be removed in ad() once simulation time passes the end of the time series + logical, private :: extendTsToEndOfSimulation = .false. ! flag indicating whether time series should be extended to provide their final value for all times after the series end time + type(ListType), pointer, private :: auxvarTsLinks => null() ! list of aux links + type(HashTableType), pointer, private :: BndTsHashTable => null() ! hash of ts to tsobj + type(TimeSeriesContainerType), allocatable, dimension(:), & + private :: TsContainers contains ! -- Public procedures procedure, public :: tsmanager_df @@ -53,9 +53,10 @@ module TimeSeriesManagerModule procedure, private :: make_link end type TimeSeriesManagerType - contains - - subroutine tsmanager_cr(this, iout, removeTsLinksOnCompletion, extendTsToEndOfSimulation) +contains + + subroutine tsmanager_cr(this, iout, removeTsLinksOnCompletion, & + extendTsToEndOfSimulation) ! ****************************************************************************** ! tsmanager_cr -- create the tsmanager ! ****************************************************************************** @@ -70,20 +71,20 @@ subroutine tsmanager_cr(this, iout, removeTsLinksOnCompletion, extendTsToEndOfSi ! ------------------------------------------------------------------------------ ! this%iout = iout - if(present(removeTsLinksOnCompletion)) then + if (present(removeTsLinksOnCompletion)) then this%removeTsLinksOnCompletion = removeTsLinksOnCompletion - endif - if(present(extendTsToEndOfSimulation)) then + end if + if (present(extendTsToEndOfSimulation)) then this%extendTsToEndOfSimulation = extendTsToEndOfSimulation - endif - allocate(this%boundTsLinks) - allocate(this%auxvarTsLinks) - allocate(this%tsfileList) - allocate(this%tsfiles(1000)) + end if + allocate (this%boundTsLinks) + allocate (this%auxvarTsLinks) + allocate (this%tsfileList) + allocate (this%tsfiles(1000)) ! return end subroutine tsmanager_cr - + subroutine tsmanager_df(this) ! ****************************************************************************** ! tsmanager_df -- define @@ -98,12 +99,12 @@ subroutine tsmanager_df(this) ! if (this%numtsfiles > 0) then call this%HashBndTimeSeries() - endif + end if ! ! -- return return end subroutine tsmanager_df - + subroutine add_tsfile(this, fname, inunit) ! ****************************************************************************** ! add_tsfile -- add a time series file to this manager @@ -128,29 +129,29 @@ subroutine add_tsfile(this, fname, inunit) if (this%numtsfiles > 0) then do i = 1, this%numtsfiles if (this%tsfiles(i) == fname) then - call store_error('Found duplicate time-series file name: ' // trim(fname)) + call store_error('Found duplicate time-series file name: '//trim(fname)) call store_error_unit(inunit) - endif - enddo - endif + end if + end do + end if ! ! -- Save fname this%numtsfiles = this%numtsfiles + 1 isize = size(this%tsfiles) if (this%numtsfiles > isize) then call ExpandArray(this%tsfiles, 1000) - endif + end if this%tsfiles(this%numtsfiles) = fname ! - ! -- + ! -- call this%tsfileList%Add(fname, this%iout, tsfile) ! return end subroutine add_tsfile - + subroutine tsmgr_ad(this) ! ****************************************************************************** -! tsmgr_ad -- time step (or subtime step) advance. Call this each time step or +! tsmgr_ad -- time step (or subtime step) advance. Call this each time step or ! subtime step. ! ****************************************************************************** ! @@ -163,15 +164,19 @@ subroutine tsmgr_ad(this) type(TimeSeriesType), pointer :: timeseries => null() integer(I4B) :: i, nlinks, nauxlinks real(DP) :: begintime, endtime, tsendtime - character(len=LENPACKAGENAME+2) :: pkgID + character(len=LENPACKAGENAME + 2) :: pkgID ! formats - character(len=*),parameter :: fmt5 = & - &"(/,'Time-series controlled values in stress period: ', i0, & - &', time step ', i0, ':')" - 10 format(a,' package: Boundary ',i0,', entry ',i0, ' value from time series "',a,'" = ',g12.5) - 15 format(a,' package: Boundary ',i0,', entry ',i0,' value from time series "',a,'" = ',g12.5,' (',a,')') - 20 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5) - 25 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5,' (',a,')') + character(len=*), parameter :: fmt5 = & + "(/,'Time-series controlled values in stress period: ', i0, & + &', time step ', i0, ':')" +10 format(a, ' package: Boundary ', i0, ', entry ', i0, & + ' value from time series "', a, '" = ', g12.5) +15 format(a, ' package: Boundary ', i0, ', entry ', i0, & + ' value from time series "', a, '" = ', g12.5, ' (', a, ')') +20 format(a, ' package: Boundary ', i0, ', ', a, & + ' value from time series "', a, '" = ', g12.5) +25 format(a, ' package: Boundary ', i0, ', ', a, & + ' value from time series "', a, '" = ', g12.5, ' (', a, ')') ! ------------------------------------------------------------------------------ ! ! -- Initialize time variables @@ -187,7 +192,7 @@ subroutine tsmgr_ad(this) ! appropriate time series. Need to do auxvartslinks ! first because they may be a multiplier column i = 1 - do while(i <= nauxlinks) + do while (i <= nauxlinks) tsLink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) timeseries => tsLink%timeSeries ! @@ -198,50 +203,51 @@ subroutine tsmgr_ad(this) call this%auxvarTsLinks%RemoveNode(i, .TRUE.) nauxlinks = this%auxvartslinks%Count() cycle - endif - endif + end if + end if ! if (i == 1) then if (tsLink%Iprpak == 1) then - write(this%iout, fmt5) kper, kstp - endif - endif - tsLink%BndElement = timeseries%GetValue(begintime, endtime, this%extendTsToEndOfSimulation) + write (this%iout, fmt5) kper, kstp + end if + end if + tsLink%BndElement = timeseries%GetValue(begintime, endtime, & + this%extendTsToEndOfSimulation) ! ! -- Write time series values to output file if (tsLink%Iprpak == 1) then - pkgID = '"' // trim(tsLink%PackageName) // '"' + pkgID = '"'//trim(tsLink%PackageName)//'"' if (tsLink%Text == '') then if (tsLink%BndName == '') then - write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 10) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif + write (this%iout, 15) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if else if (tsLink%BndName == '') then - write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 20) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - endif - endif + write (this%iout, 25) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if + end if + end if ! i = i + 1 - enddo + end do ! ! -- Iterate through boundtslinks and replace specified ! elements of bound with average value obtained from ! appropriate time series. (For list-type packages) i = 1 - do while(i <= nlinks) + do while (i <= nlinks) tsLink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) timeseries => tsLink%timeSeries ! @@ -252,68 +258,69 @@ subroutine tsmgr_ad(this) call this%boundTsLinks%RemoveNode(i, .TRUE.) nlinks = this%boundTsLinks%Count() cycle - endif - endif + end if + end if ! if (i == 1 .and. nauxlinks == 0) then if (tsLink%Iprpak == 1) then - write(this%iout, fmt5) kper, kstp - endif - endif + write (this%iout, fmt5) kper, kstp + end if + end if ! this part needs to be different for MAW because MAW does not use ! bound array for well rate (although rate is stored in ! this%bound(4,ibnd)), it uses this%mawwells(n)%rate%value if (tsLink%UseDefaultProc) then timeseries => tsLink%timeSeries - tsLink%BndElement = timeseries%GetValue(begintime, endtime, this%extendTsToEndOfSimulation) + tsLink%BndElement = timeseries%GetValue(begintime, endtime, & + this%extendTsToEndOfSimulation) ! - ! -- If multiplier is active and it applies to this element, + ! -- If multiplier is active and it applies to this element, ! do the multiplication. This must be done after the auxlinks ! have been calculated in case iauxmultcol is being used. if (associated(tsLink%RMultiplier)) then tsLink%BndElement = tsLink%BndElement * tsLink%RMultiplier - endif + end if ! ! -- Write time series values to output files if (tsLink%Iprpak == 1) then - pkgID = '"' // trim(tsLink%PackageName) // '"' + pkgID = '"'//trim(tsLink%PackageName)//'"' if (tsLink%Text == '') then if (tsLink%BndName == '') then - write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 10) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif + write (this%iout, 15) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if else if (tsLink%BndName == '') then - write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 20) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - endif - endif + write (this%iout, 25) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if + end if + end if ! ! -- If conversion from flux to flow is required, multiply by cell area if (tsLink%ConvertFlux) then tsLink%BndElement = tsLink%BndElement * tsLink%CellArea - endif - endif + end if + end if ! i = i + 1 - enddo + end do ! ! -- Finish with ending line if (nlinks + nauxlinks > 0) then if (tsLink%Iprpak == 1) then - write(this%iout,'()') - endif + write (this%iout, '()') + end if end if ! return @@ -333,22 +340,22 @@ subroutine tsmgr_da(this) ! ! -- Deallocate time-series links in boundTsLinks call this%boundTsLinks%Clear(.true.) - deallocate(this%boundTsLinks) + deallocate (this%boundTsLinks) ! ! -- Deallocate time-series links in auxvarTsLinks call this%auxvarTsLinks%Clear(.true.) - deallocate(this%auxvarTsLinks) + deallocate (this%auxvarTsLinks) ! ! -- Deallocate tsfileList call this%tsfileList%da() - deallocate(this%tsfileList) + deallocate (this%tsfileList) ! ! -- Deallocate the hash table if (associated(this%BndTsHashTable)) then call hash_table_da(this%BndTsHashTable) end if ! - deallocate(this%tsfiles) + deallocate (this%tsfiles) ! return end subroutine tsmgr_da @@ -365,7 +372,7 @@ subroutine Reset(this, pkgName) class(TimeSeriesManagerType) :: this character(len=*), intent(in) :: pkgName ! -- local - integer(I4B) :: i, nlinks + integer(I4B) :: i, nlinks type(TimeSeriesLinkType), pointer :: tslink ! ------------------------------------------------------------------------------ ! Zero out values for time-series controlled stresses. @@ -376,34 +383,34 @@ subroutine Reset(this, pkgName) ! ! Reassign all linked elements to zero nlinks = this%boundTsLinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) if (associated(tslink)) then if (tslink%PackageName == pkgName) then tslink%BndElement = DZERO - endif - endif - enddo + end if + end if + end do ! ! Remove links belonging to calling package nlinks = this%boundTsLinks%Count() - do i=nlinks,1,-1 + do i = nlinks, 1, -1 tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) if (associated(tslink)) then if (tslink%PackageName == pkgName) then call this%boundTsLinks%RemoveNode(i, .true.) - endif - endif - enddo + end if + end if + end do nlinks = this%auxvarTsLinks%Count() - do i=nlinks,1,-1 - tslink => GetTimeSeriesLinkFromList(this%auxvarTsLinks,i) + do i = nlinks, 1, -1 + tslink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) if (associated(tslink)) then if (tslink%PackageName == pkgName) then call this%auxvarTsLinks%RemoveNode(i, .true.) - endif - endif - enddo + end if + end if + end do ! return end subroutine Reset @@ -411,22 +418,22 @@ end subroutine Reset subroutine make_link(this, timeSeries, pkgName, auxOrBnd, bndElem, & irow, jcol, iprpak, tsLink, text, bndName) ! ****************************************************************************** -! make_link -- +! make_link -- ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesManagerType), intent(inout) :: this - type(TimeSeriesType), pointer, intent(inout) :: timeSeries - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - real(DP), pointer, intent(inout) :: bndElem - integer(I4B), intent(in) :: irow, jcol - integer(I4B), intent(in) :: iprpak + class(TimeSeriesManagerType), intent(inout) :: this + type(TimeSeriesType), pointer, intent(inout) :: timeSeries + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + real(DP), pointer, intent(inout) :: bndElem + integer(I4B), intent(in) :: irow, jcol + integer(I4B), intent(in) :: iprpak type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink - character(len=*), intent(in) :: text - character(len=*), intent(in) :: bndName + character(len=*), intent(in) :: text + character(len=*), intent(in) :: bndName ! -- local ! ------------------------------------------------------------------------------ ! @@ -440,17 +447,17 @@ subroutine make_link(this, timeSeries, pkgName, auxOrBnd, bndElem, & call AddTimeSeriesLinkToList(this%auxvarTsLinks, tsLink) else call store_error('programmer error in make_link', terminate=.TRUE.) - endif + end if tsLink%Text = text tsLink%BndName = bndName - endif + end if ! return end subroutine make_link function GetLink(this, auxOrBnd, indx) result(tsLink) ! ****************************************************************************** -! GetLink -- +! GetLink -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -458,7 +465,7 @@ function GetLink(this, auxOrBnd, indx) result(tsLink) ! -- dummy class(TimeSeriesManagerType) :: this character(len=3), intent(in) :: auxOrBnd - integer(I4B), intent(in) :: indx + integer(I4B), intent(in) :: indx type(TimeSeriesLinkType), pointer :: tsLink ! -- local type(ListType), pointer :: list @@ -476,14 +483,14 @@ function GetLink(this, auxOrBnd, indx) result(tsLink) ! if (associated(list)) then tsLink => GetTimeSeriesLinkFromList(list, indx) - endif + end if ! return end function GetLink function CountLinks(this, auxOrBnd) ! ****************************************************************************** -! CountLinks -- +! CountLinks -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -500,21 +507,21 @@ function CountLinks(this, auxOrBnd) CountLinks = this%boundTsLinks%Count() elseif (auxOrBnd == 'AUX') then CountLinks = this%auxvarTsLinks%count() - endif + end if ! return end function CountLinks - function get_time_series(this, name) result (res) + function get_time_series(this, name) result(res) ! ****************************************************************************** -! get_time_series -- +! get_time_series -- ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=*), intent(in) :: name + class(TimeSeriesManagerType) :: this + character(len=*), intent(in) :: name ! -- result type(TimeSeriesType), pointer :: res ! -- local @@ -527,14 +534,14 @@ function get_time_series(this, name) result (res) indx = this%BndTsHashTable%get_index(name) if (indx > 0) then res => this%TsContainers(indx)%timeSeries - endif + end if ! return end function get_time_series subroutine HashBndTimeSeries(this) ! ****************************************************************************** -! HashBndTimeSeries -- +! HashBndTimeSeries -- ! Store all boundary (stress) time series links in ! TsContainers and construct hash table BndTsHashTable. ! ****************************************************************************** @@ -542,7 +549,7 @@ subroutine HashBndTimeSeries(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class (TimeSeriesManagerType), intent(inout) :: this + class(TimeSeriesManagerType), intent(inout) :: this ! -- local integer(I4B) :: i, j, k, numtsfiles, numts character(len=LENTIMESERIESNAME) :: name @@ -554,7 +561,7 @@ subroutine HashBndTimeSeries(this) ! ! Allocate the TsContainers array to accommodate all time-series links. numts = this%tsfileList%CountTimeSeries() - allocate(this%TsContainers(numts)) + allocate (this%TsContainers(numts)) ! ! Store a pointer to each time series in the TsContainers array ! and put its key (time-series name) and index in the hash table. @@ -563,51 +570,51 @@ subroutine HashBndTimeSeries(this) do i = 1, numtsfiles tsfile => this%tsfileList%Gettsfile(i) numts = tsfile%Count() - do j=1,numts + do j = 1, numts k = k + 1 this%TsContainers(k)%timeSeries => tsfile%GetTimeSeries(j) if (associated(this%TsContainers(k)%timeSeries)) then name = this%TsContainers(k)%timeSeries%Name call this%BndTsHashTable%add_entry(name, k) - endif - enddo - enddo + end if + end do + end do ! return end subroutine HashBndTimeSeries ! -- Non-type-bound procedures - subroutine read_value_or_time_series(textInput, ii, jj, bndElem, & - pkgName, auxOrBnd, tsManager, iprpak, tsLink) + subroutine read_value_or_time_series(textInput, ii, jj, bndElem, pkgName, & + auxOrBnd, tsManager, iprpak, tsLink) ! ****************************************************************************** -! read_value_or_time_series -- +! read_value_or_time_series -- ! Call this subroutine if the time-series link is available or needed. ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - character(len=*), intent(in) :: textInput - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - real(DP), pointer, intent(inout) :: bndElem - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: textInput + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + real(DP), pointer, intent(inout) :: bndElem + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + type(TimeSeriesManagerType), intent(inout) :: tsManager + integer(I4B), intent(in) :: iprpak type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink ! -- local - type(TimeSeriesType), pointer :: timeseries => null() + type(TimeSeriesType), pointer :: timeseries => null() type(TimeSeriesLinkType), pointer :: tslTemp => null() - integer(I4B) :: i, istat, nlinks - real(DP) :: r + integer(I4B) :: i, istat, nlinks + real(DP) :: r character(len=LINELENGTH) :: errmsg character(len=LENTIMESERIESNAME) :: tsNameTemp logical :: found ! ------------------------------------------------------------------------------ ! - read (textInput,*,iostat=istat) r + read (textInput, *, iostat=istat) r if (istat == 0) then bndElem = r else @@ -621,53 +628,54 @@ subroutine read_value_or_time_series(textInput, ii, jj, bndElem, & if (associated(timeseries)) then ! -- Assign value from time series to current ! array element - r = timeseries%GetValue(totimsav, totim, tsManager%extendTsToEndOfSimulation) + r = timeseries%GetValue(totimsav, totim, & + tsManager%extendTsToEndOfSimulation) bndElem = r ! Look to see if this array element already has a time series ! linked to it. If not, make a link to it. nlinks = tsManager%CountLinks(auxOrBnd) found = .false. - searchlinks: do i=1,nlinks + searchlinks: do i = 1, nlinks tslTemp => tsManager%GetLink(auxOrBnd, i) if (tslTemp%PackageName == pkgName) then - ! -- Check ii, jj against iRow, jCol stored in link - if (tslTemp%IRow==ii .and. tslTemp%JCol==jj) then - ! -- This array element is already linked to a time series. - tsLink => tslTemp - found = .true. - exit searchlinks - endif - endif - enddo searchlinks + ! -- Check ii, jj against iRow, jCol stored in link + if (tslTemp%IRow == ii .and. tslTemp%JCol == jj) then + ! -- This array element is already linked to a time series. + tsLink => tslTemp + found = .true. + exit searchlinks + end if + end if + end do searchlinks if (.not. found) then ! -- Link was not found. Make one and add it to the list. - call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & + call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & ii, jj, iprpak, tsLink, '', '') - endif + end if else - errmsg = 'Error in list input. Expected numeric value or ' // & - "time-series name, but found '" // trim(textInput) // "'." + errmsg = 'Error in list input. Expected numeric value or '// & + "time-series name, but found '"//trim(textInput)//"'." call store_error(errmsg) - endif - endif + end if + end if end subroutine read_value_or_time_series - subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & + subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & auxOrBnd, tsManager, iprpak, varName) ! ****************************************************************************** -! read_value_or_time_series_adv -- Call this subroutine from advanced +! read_value_or_time_series_adv -- Call this subroutine from advanced ! packages to define timeseries link for a variable (varName). ! ! -- Arguments are as follows: ! textInput : string that is either a float or a string name -! ii : column number -! jj : row number -! bndElem : pointer to a position in an array in package pkgName +! ii : column number +! jj : row number +! bndElem : pointer to a position in an array in package pkgName ! pkgName : package name ! auxOrBnd : 'AUX' or 'BND' keyword ! tsManager : timeseries manager object for package ! iprpak : integer flag indicating if interpolated timeseries values -! should be printed to package iout during TsManager%ad() +! should be printed to package iout during TsManager%ad() ! varName : variable name ! ! ****************************************************************************** @@ -675,22 +683,22 @@ subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - character(len=*), intent(in) :: textInput - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - real(DP), pointer, intent(inout) :: bndElem - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd + character(len=*), intent(in) :: textInput + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + real(DP), pointer, intent(inout) :: bndElem + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: iprpak - character(len=*), intent(in) :: varName + integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: varName ! -- local integer(I4B) :: istat real(DP) :: v character(len=LINELENGTH) :: errmsg character(len=LENTIMESERIESNAME) :: tsNameTemp logical :: found - type(TimeSeriesType), pointer :: timeseries => null() + type(TimeSeriesType), pointer :: timeseries => null() type(TimeSeriesLinkType), pointer :: tsLink => null() ! ------------------------------------------------------------------------------ ! @@ -704,10 +712,10 @@ subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & bndElem = v ! ! -- remove existing link if it exists for this boundary element - found = remove_existing_link(tsManager, ii, jj, pkgName, & + found = remove_existing_link(tsManager, ii, jj, pkgName, & auxOrBnd, varName) - ! - ! -- timeseries + ! + ! -- timeseries else ! ! -- attempt to read numeric value from textInput failed. @@ -724,37 +732,38 @@ subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & if (associated(timeseries)) then ! ! -- Assign average value from time series to current array element - v = timeseries%GetValue(totimsav, totim, tsManager%extendTsToEndOfSimulation) + v = timeseries%GetValue(totimsav, totim, & + tsManager%extendTsToEndOfSimulation) bndElem = v ! ! -- remove existing link if it exists for this boundary element - found = remove_existing_link(tsManager, ii, jj, & + found = remove_existing_link(tsManager, ii, jj, & pkgName, auxOrBnd, varName) ! ! -- Add link to the list. - call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & + call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & ii, jj, iprpak, tsLink, varName, '') - ! - ! -- not a valid timeseries name + ! + ! -- not a valid timeseries name else - errmsg = 'Error in list input. Expected numeric value or ' // & - "time-series name, but found '" // trim(textInput) // "'." + errmsg = 'Error in list input. Expected numeric value or '// & + "time-series name, but found '"//trim(textInput)//"'." call store_error(errmsg) end if end if return end subroutine read_value_or_time_series_adv -! +! ! -- private subroutines - function remove_existing_link(tsManager, ii, jj, & + function remove_existing_link(tsManager, ii, jj, & pkgName, auxOrBnd, varName) result(found) ! ****************************************************************************** ! remove_existing_link -- remove an existing timeseries link if it is defined. ! ! -- Arguments are as follows: ! tsManager : timeseries manager object for package -! ii : column number -! jj : row number +! ii : column number +! jj : row number ! pkgName : package name ! auxOrBnd : 'AUX' or 'BND' keyword ! varName : variable name @@ -767,11 +776,11 @@ function remove_existing_link(tsManager, ii, jj, & logical :: found ! -- dummy type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - character(len=*), intent(in) :: varName + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + character(len=*), intent(in) :: varName ! -- local integer(I4B) :: i integer(I4B) :: nlinks @@ -786,12 +795,12 @@ function remove_existing_link(tsManager, ii, jj, & csearchlinks: do i = 1, nlinks tslTemp => tsManager%GetLink(auxOrBnd, i) ! - ! -- Check ii against iRow, jj against jCol, and varName + ! -- Check ii against iRow, jj against jCol, and varName ! against Text member of link if (tslTemp%PackageName == pkgName) then ! ! -- This array element is already linked to a time series. - if (tslTemp%IRow == ii .and. tslTemp%JCol == jj .and. & + if (tslTemp%IRow == ii .and. tslTemp%JCol == jj .and. & same_word(tslTemp%Text, varName)) then found = .TRUE. removeLink = i diff --git a/src/Utilities/TimeSeries/TimeSeriesRecord.f90 b/src/Utilities/TimeSeries/TimeSeriesRecord.f90 index b161f70d267..8bfb1bc735c 100644 --- a/src/Utilities/TimeSeries/TimeSeriesRecord.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesRecord.f90 @@ -1,5 +1,5 @@ module TimeSeriesRecordModule - + use KindModule, only: DP, I4B use ListModule, only: ListType @@ -21,7 +21,7 @@ subroutine ConstructTimeSeriesRecord(newTsRecord, time, value) type(TimeSeriesRecordType), pointer, intent(out) :: newTsRecord real(DP), intent(in) :: time, value ! - allocate(newTsRecord) + allocate (newTsRecord) newTsRecord%tsrTime = time newTsRecord%tsrValue = value return @@ -46,7 +46,7 @@ end function CastAsTimeSeriesRecordType subroutine AddTimeSeriesRecordToList(list, tsrecord) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecord ! -- local class(*), pointer :: obj => null() diff --git a/src/Utilities/Timer.f90 b/src/Utilities/Timer.f90 index 01b73632c8d..14358101ac4 100644 --- a/src/Utilities/Timer.f90 +++ b/src/Utilities/Timer.f90 @@ -1,5 +1,5 @@ module TimerModule - + use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, DZERO use GenericUtilitiesModule, only: sim_message @@ -9,9 +9,9 @@ module TimerModule public :: elapsed_time public :: code_timer integer(I4B), dimension(8) :: ibdt - - contains - + +contains + subroutine start_time() ! ****************************************************************************** ! Start simulation timer @@ -24,20 +24,20 @@ subroutine start_time() character(len=LINELENGTH) :: line integer(I4B) :: i ! -- format - character(len=*), parameter :: fmtdt = & - "(1X,'Run start date and time (yyyy/mm/dd hh:mm:ss): ', & + character(len=*), parameter :: fmtdt = & + "(1X,'Run start date and time (yyyy/mm/dd hh:mm:ss): ', & &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" ! ------------------------------------------------------------------------------ - ! + ! ! -- Get current date and time, assign to IBDT, and write to screen call date_and_time(values=ibdt) - write(line, fmtdt) (ibdt(i), i = 1, 3), (ibdt(i), i = 5, 7) + write (line, fmtdt) (ibdt(i), i=1, 3), (ibdt(i), i=5, 7) call sim_message(line, skipafter=1) ! ! -- return return end subroutine start_time - + SUBROUTINE elapsed_time(iout, iprtim) ! ****************************************************************************** ! Get end time and calculate elapsed time @@ -56,111 +56,111 @@ SUBROUTINE elapsed_time(iout, iprtim) integer(I4B) :: ndays, leap, ibd, ied, mb, me, nm, mc, m integer(I4B) :: nhours, nmins, nsecs, msecs, nrsecs real(DP) :: elsec, rsecs - DATA IDPM/31,28,31,30,31,30,31,31,30,31,30,31/ ! Days per month - DATA NSPD/86400/ ! Seconds per day + DATA IDPM/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ ! Days per month + DATA NSPD/86400/ ! Seconds per day ! -- format - character(len=*), parameter :: fmtdt = & - "(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & + character(len=*), parameter :: fmtdt = & + "(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" ! ------------------------------------------------------------------------------ ! ! Get current date and time, assign to IEDT, and write. - CALL DATE_AND_TIME(VALUES=IEDT) - ! - ! -- write elapsed time to stdout - write(line,fmtdt) (IEDT(I),I=1,3),(IEDT(I),I=5,7) - call sim_message(line, skipbefore=1) - ! - ! -- write elapsted time to iout - IF(IPRTIM.GT.0) THEN - call sim_message(line, iunit=iout, skipbefore=1) - END IF + CALL DATE_AND_TIME(VALUES=IEDT) + ! + ! -- write elapsed time to stdout + write (line, fmtdt) (IEDT(I), I=1, 3), (IEDT(I), I=5, 7) + call sim_message(line, skipbefore=1) + ! + ! -- write elapsted time to iout + IF (IPRTIM .GT. 0) THEN + call sim_message(line, iunit=iout, skipbefore=1) + END IF ! ! Calculate elapsed time in days and seconds - NDAYS=0 - LEAP=0 - IF (MOD(IEDT(1),4).EQ.0) LEAP = 1 - IBD = IBDT(3) ! BEGIN DAY - IED = IEDT(3) ! END DAY + NDAYS = 0 + LEAP = 0 + IF (MOD(IEDT(1), 4) .EQ. 0) LEAP = 1 + IBD = IBDT(3) ! BEGIN DAY + IED = IEDT(3) ! END DAY ! FIND DAYS - IF (IBDT(2).NE.IEDT(2)) THEN + IF (IBDT(2) .NE. IEDT(2)) THEN ! MONTHS DIFFER - MB = IBDT(2) ! BEGIN MONTH - ME = IEDT(2) ! END MONTH - NM = ME-MB+1 ! NUMBER OF MONTHS TO LOOK AT - IF (MB.GT.ME) NM = NM+12 - MC=MB-1 - DO M=1,NM - MC=MC+1 ! MC IS CURRENT MONTH - IF (MC.EQ.13) MC = 1 - IF (MC.EQ.MB) THEN - NDAYS = NDAYS+IDPM(MC)-IBD - IF (MC.EQ.2) NDAYS = NDAYS + LEAP - ELSEIF (MC.EQ.ME) THEN - NDAYS = NDAYS+IED - ELSE - NDAYS = NDAYS+IDPM(MC) - IF (MC.EQ.2) NDAYS = NDAYS + LEAP - ENDIF - ENDDO - ELSEIF (IBD.LT.IED) THEN + MB = IBDT(2) ! BEGIN MONTH + ME = IEDT(2) ! END MONTH + NM = ME - MB + 1 ! NUMBER OF MONTHS TO LOOK AT + IF (MB .GT. ME) NM = NM + 12 + MC = MB - 1 + DO M = 1, NM + MC = MC + 1 ! MC IS CURRENT MONTH + IF (MC .EQ. 13) MC = 1 + IF (MC .EQ. MB) THEN + NDAYS = NDAYS + IDPM(MC) - IBD + IF (MC .EQ. 2) NDAYS = NDAYS + LEAP + ELSEIF (MC .EQ. ME) THEN + NDAYS = NDAYS + IED + ELSE + NDAYS = NDAYS + IDPM(MC) + IF (MC .EQ. 2) NDAYS = NDAYS + LEAP + END IF + END DO + ELSEIF (IBD .LT. IED) THEN ! START AND END IN SAME MONTH, ONLY ACCOUNT FOR DAYS - NDAYS = IED-IBD - ENDIF - ELSEC=NDAYS*NSPD + NDAYS = IED - IBD + END IF + ELSEC = NDAYS * NSPD ! ! ADD OR SUBTRACT SECONDS - ELSEC = ELSEC+(IEDT(5)-IBDT(5))*3600.0 - ELSEC = ELSEC+(IEDT(6)-IBDT(6))*60.0 - ELSEC = ELSEC+(IEDT(7)-IBDT(7)) - ELSEC = ELSEC+(IEDT(8)-IBDT(8))*0.001 + ELSEC = ELSEC + (IEDT(5) - IBDT(5)) * 3600.0 + ELSEC = ELSEC + (IEDT(6) - IBDT(6)) * 60.0 + ELSEC = ELSEC + (IEDT(7) - IBDT(7)) + ELSEC = ELSEC + (IEDT(8) - IBDT(8)) * 0.001 ! ! CONVERT SECONDS TO DAYS, HOURS, MINUTES, AND SECONDS - NDAYS = INT(ELSEC/NSPD) - RSECS = MOD(ELSEC, 86400.0_DP) - NHOURS = INT(RSECS/3600.0) - RSECS = MOD(RSECS,3600.0_DP) - NMINS = INT(RSECS/60.0) - RSECS = MOD(RSECS,60.0_DP) - NSECS = INT(RSECS) - RSECS = MOD(RSECS,1.0_DP) - MSECS = NINT(RSECS*1000.0) - NRSECS = NSECS - IF (RSECS.GE.0.5) NRSECS=NRSECS+1 + NDAYS = INT(ELSEC / NSPD) + RSECS = MOD(ELSEC, 86400.0_DP) + NHOURS = INT(RSECS / 3600.0) + RSECS = MOD(RSECS, 3600.0_DP) + NMINS = INT(RSECS / 60.0) + RSECS = MOD(RSECS, 60.0_DP) + NSECS = INT(RSECS) + RSECS = MOD(RSECS, 1.0_DP) + MSECS = NINT(RSECS * 1000.0) + NRSECS = NSECS + IF (RSECS .GE. 0.5) NRSECS = NRSECS + 1 ! ! Write elapsed time to screen - IF (NDAYS.GT.0) THEN - WRITE(line, 1010) NDAYS,NHOURS,NMINS,NRSECS - 1010 FORMAT(1X,'Elapsed run time: ',I3,' Days, ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds') - ELSEIF (NHOURS.GT.0) THEN - WRITE(line, 1020) NHOURS,NMINS,NRSECS - 1020 FORMAT(1X,'Elapsed run time: ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds') - ELSEIF (NMINS.GT.0) THEN - WRITE(line, 1030) NMINS,NSECS,MSECS - 1030 FORMAT(1X,'Elapsed run time: ',I2,' Minutes, ', & - I2,'.',I3.3,' Seconds') - ELSE - WRITE(line, 1040) NSECS,MSECS - 1040 FORMAT(1X,'Elapsed run time: ',I2,'.',I3.3,' Seconds') - ENDIF - call sim_message(line, skipafter=1) + IF (NDAYS .GT. 0) THEN + WRITE (line, 1010) NDAYS, NHOURS, NMINS, NRSECS +1010 FORMAT(1X, 'Elapsed run time: ', I3, ' Days, ', I2, ' Hours, ', I2, & + ' Minutes, ', I2, ' Seconds') + ELSEIF (NHOURS .GT. 0) THEN + WRITE (line, 1020) NHOURS, NMINS, NRSECS +1020 FORMAT(1X, 'Elapsed run time: ', I2, ' Hours, ', I2, & + ' Minutes, ', I2, ' Seconds') + ELSEIF (NMINS .GT. 0) THEN + WRITE (line, 1030) NMINS, NSECS, MSECS +1030 FORMAT(1X, 'Elapsed run time: ', I2, ' Minutes, ', & + I2, '.', I3.3, ' Seconds') + ELSE + WRITE (line, 1040) NSECS, MSECS +1040 FORMAT(1X, 'Elapsed run time: ', I2, '.', I3.3, ' Seconds') + END IF + call sim_message(line, skipafter=1) ! ! Write times to file if requested - IF(IPRTIM.GT.0) THEN - IF (NDAYS.GT.0) THEN - WRITE(IOUT,1010) NDAYS,NHOURS,NMINS,NRSECS - ELSEIF (NHOURS.GT.0) THEN - WRITE(IOUT,1020) NHOURS,NMINS,NRSECS - ELSEIF (NMINS.GT.0) THEN - WRITE(IOUT,1030) NMINS,NSECS,MSECS - ELSE - WRITE(IOUT,1040) NSECS,MSECS - ENDIF - ENDIF + IF (IPRTIM .GT. 0) THEN + IF (NDAYS .GT. 0) THEN + WRITE (IOUT, 1010) NDAYS, NHOURS, NMINS, NRSECS + ELSEIF (NHOURS .GT. 0) THEN + WRITE (IOUT, 1020) NHOURS, NMINS, NRSECS + ELSEIF (NMINS .GT. 0) THEN + WRITE (IOUT, 1030) NMINS, NSECS, MSECS + ELSE + WRITE (IOUT, 1040) NSECS, MSECS + END IF + END IF ! - RETURN + RETURN END SUBROUTINE elapsed_time ! @@ -190,5 +190,5 @@ SUBROUTINE code_timer(it, t1, ts) ! -- RETURN RETURN END SUBROUTINE code_timer - + end module TimerModule diff --git a/src/Utilities/VectorInt.f90 b/src/Utilities/VectorInt.f90 index 91fbc060880..405cf5f87a0 100644 --- a/src/Utilities/VectorInt.f90 +++ b/src/Utilities/VectorInt.f90 @@ -4,44 +4,44 @@ module VectorIntModule use ArrayHandlersModule, only: ExpandArray implicit none private - public :: VectorInt - + public :: VectorInt + integer(I4B), parameter :: defaultInitialCapacity = 4 - + ! This is a dynamic vector type for integers type :: VectorInt integer(I4B), private, allocatable :: values(:) ! the internal array for storage - integer(I4B) :: size ! the number of elements (technically this stuff should be unsigned) - integer(I4B) :: capacity ! the reserved storage + integer(I4B) :: size ! the number of elements (technically this stuff should be unsigned) + integer(I4B) :: capacity ! the reserved storage contains - procedure, pass(this) :: init ! allocate memory, init size and capacity - procedure, pass(this) :: push_back ! adds an element at the end of the vector - procedure, pass(this) :: at ! random access, unsafe, no bounds checking - procedure, pass(this) :: at_safe ! random access with bounds checking - procedure, pass(this) :: clear ! empties the vector, leaves memory unchanged - procedure, pass(this) :: shrink_to_fit ! reduces the allocated memory to fit the actual vector size - procedure, pass(this) :: destroy ! deletes the memory + procedure, pass(this) :: init ! allocate memory, init size and capacity + procedure, pass(this) :: push_back ! adds an element at the end of the vector + procedure, pass(this) :: at ! random access, unsafe, no bounds checking + procedure, pass(this) :: at_safe ! random access with bounds checking + procedure, pass(this) :: clear ! empties the vector, leaves memory unchanged + procedure, pass(this) :: shrink_to_fit ! reduces the allocated memory to fit the actual vector size + procedure, pass(this) :: destroy ! deletes the memory ! private procedure, private, pass(this) :: expand end type VectorInt contains ! module routines - + subroutine init(this, capacity) class(VectorInt), intent(inout) :: this integer(I4B), intent(in), optional :: capacity ! the initial capacity, when given - + if (present(capacity)) then this%capacity = capacity else this%capacity = defaultInitialCapacity - end if - - allocate(this%values(this%capacity)) + end if + + allocate (this%values(this%capacity)) this%size = 0 - + end subroutine init - + subroutine push_back(this, newValue) class(VectorInt), intent(inout) :: this integer(I4B) :: newValue @@ -49,95 +49,96 @@ subroutine push_back(this, newValue) if (this%size + 1 > this%capacity) then call this%expand() end if - + this%size = this%size + 1 this%values(this%size) = newValue - + end subroutine push_back - + function at(this, idx) result(value) class(VectorInt), intent(inout) :: this - integer(I4B), intent(in) :: idx - integer(I4B) :: value - + integer(I4B), intent(in) :: idx + integer(I4B) :: value + value = this%values(idx) - + end function at - + function at_safe(this, idx) result(value) class(VectorInt), intent(inout) :: this - integer(I4B), intent(in) :: idx - integer(I4B) :: value - + integer(I4B), intent(in) :: idx + integer(I4B) :: value + if (idx > this%size) then - write(*,*) 'VectorInt exception: access out of bounds, index ', idx, ' exceeds actual size (', this%size, ')' + write (*, *) 'VectorInt exception: access out of bounds, index ', idx, & + ' exceeds actual size (', this%size, ')' call ustop() end if value = this%at(idx) - + end function at_safe - + subroutine clear(this) class(VectorInt), intent(inout) :: this - + ! really, this is all there is to it... this%size = 0 - + end subroutine clear - + subroutine shrink_to_fit(this) class(VectorInt), intent(inout) :: this ! local integer(I4B), allocatable :: tempValues(:) integer(I4B) :: i, newSize - + if (this%size == this%capacity) then - return + return end if - + ! store temp newSize = this%size - allocate(tempValues(newSize)) + allocate (tempValues(newSize)) do i = 1, newSize - tempValues(i) = this%values(i) + tempValues(i) = this%values(i) end do - + ! reinit call this%destroy() call this%init(newSize) - + ! copy back do i = 1, newSize - call this%push_back(tempValues(i)) + call this%push_back(tempValues(i)) end do - + end subroutine shrink_to_fit - + subroutine destroy(this) class(VectorInt), intent(inout) :: this - + if (allocated(this%values)) then - deallocate(this%values) + deallocate (this%values) this%size = 0 this%capacity = 0 else - write(*,*) 'VectorInt exception: cannot delete an unallocated array' + write (*, *) 'VectorInt exception: cannot delete an unallocated array' call ustop() end if - + end subroutine destroy - + ! expand the array with the given strategy, at ! least by 1 subroutine expand(this) class(VectorInt), intent(inout) :: this integer(I4B) :: increment - + ! expansion strategy - increment = this%capacity/2 + 1 + increment = this%capacity / 2 + 1 call ExpandArray(this%values, increment) this%capacity = this%capacity + increment - + end subroutine expand - + end module VectorIntModule diff --git a/src/Utilities/comarg.f90 b/src/Utilities/comarg.f90 index 9eae7118541..f9d328dee06 100644 --- a/src/Utilities/comarg.f90 +++ b/src/Utilities/comarg.f90 @@ -1,14 +1,14 @@ module CommandArguments use KindModule - use ConstantsModule, only: LINELENGTH, LENBIGLINE, LENHUGELINE, & - VSUMMARY, VALL, VDEBUG, & + use ConstantsModule, only: LINELENGTH, LENBIGLINE, LENHUGELINE, & + VSUMMARY, VALL, VDEBUG, & MVALIDATE - use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE, & - FMTDISCLAIMER, FMTLICENSE + use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE, & + FMTDISCLAIMER, FMTLICENSE use CompilerVersion - use SimVariablesModule, only: istdout, isim_level, & - simfile, simlstfile, simstdout, & - isim_mode + use SimVariablesModule, only: istdout, isim_level, & + simfile, simlstfile, simstdout, & + isim_mode use GenericUtilitiesModule, only: sim_message, write_message use SimModule, only: store_error, ustop use InputOutputModule, only: upcase, getunit @@ -18,8 +18,8 @@ module CommandArguments private public :: GetCommandLineArguments ! - contains - +contains + !> @brief Get command line arguments !! !! Subroutine to get and write information on command line arguments. @@ -56,7 +56,7 @@ subroutine GetCommandLineArguments() call get_command_argument(0, cexe) cexe = adjustl(cexe) ! - ! -- find the program basename, not including the path (this should be + ! -- find the program basename, not including the path (this should be ! mf6.exe, mf6d.exe, etc.) ipos = index(cexe, '/', back=.TRUE.) if (ipos == 0) then @@ -71,8 +71,8 @@ subroutine GetCommandLineArguments() ! ! -- write header call get_compile_date(cdate) - write(header, '(a,4(1x,a),a)') & - trim(adjustl(cexe)), '- MODFLOW', & + write (header, '(a,4(1x,a),a)') & + trim(adjustl(cexe)), '- MODFLOW', & trim(adjustl(VERSION)), '(compiled', trim(adjustl(cdate)), ')' ! ! -- set ctyp @@ -88,12 +88,12 @@ subroutine GetCommandLineArguments() do iarg = 1, icountcmd call get_command_argument(iarg, uctag) call upcase(uctag) - if (trim(adjustl(uctag)) == '-S' .or. & - trim(adjustl(uctag)) == '--SILENT') then + if (trim(adjustl(uctag)) == '-S' .or. & + trim(adjustl(uctag)) == '--SILENT') then ! ! -- get file unit and open mfsim.stdout istdout = getunit() - open(unit=istdout, file=trim(adjustl(simstdout))) + open (unit=istdout, file=trim(adjustl(simstdout))) ! ! -- exit loop exit @@ -127,9 +127,9 @@ subroutine GetCommandLineArguments() if (ipos > 0) then ipos = index(tag, '=') ilen = len_trim(tag) - clevel = tag(ipos+1:ilen) + clevel = tag(ipos + 1:ilen) call upcase(clevel) - uctag = tag(1:ipos-1) + uctag = tag(1:ipos - 1) call upcase(uctag) end if ! @@ -139,110 +139,110 @@ subroutine GetCommandLineArguments() if (ipos > 0) then ipos = index(tag, '=') ilen = len_trim(tag) - cmode = tag(ipos+1:ilen) + cmode = tag(ipos + 1:ilen) call upcase(cmode) - uctag = tag(1:ipos-1) + uctag = tag(1:ipos - 1) call upcase(uctag) end if ! ! -- evaluate the command line argument (uctag) - select case(trim(adjustl(uctag))) - case('-H', '-?', '--HELP') - lstop = .TRUE. + select case (trim(adjustl(uctag))) + case ('-H', '-?', '--HELP') + lstop = .TRUE. + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + case ('-V', '--VERSION') + lstop = .TRUE. + write (line, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp + call write_message(line, skipbefore=1, skipafter=1) + case ('-DEV', '--DEVELOP') + lstop = .TRUE. + write (line, '(2a,g0)') & + trim(adjustl(cexe)), ': develop version ', ltyp + call write_message(line, skipbefore=1, skipafter=1) + case ('-C', '--COMPILER') + lstop = .TRUE. + call get_compiler(compiler) + write (line, '(2a,1x,a)') & + trim(adjustl(cexe)), ':', trim(adjustl(compiler)) + call write_message(line, skipbefore=1, skipafter=1) + case ('-S', '--SILENT') + write (line, '(2a,1x,a)') & + trim(adjustl(cexe)), ':', 'all screen output sent to mfsim.stdout' + call write_message(line, skipbefore=1, skipafter=1) + case ('-D', '--DISCLAIMER') + lstop = .TRUE. + call sim_message('', fmt=FMTDISCLAIMER) + case ('-LIC', '--LICENSE') + lstop = .TRUE. + call sim_message('', fmt=FMTLICENSE) + case ('-CO', '--COMPILER-OPT') + lstop = .TRUE. + call get_compile_options(coptions) + call write_message(coptions, skipbefore=1, skipafter=1) + case ('-L', '--LEVEL') + if (len_trim(clevel) < 1) then + iarg = iarg + 1 + call get_command_argument(iarg, clevel) + call upcase(clevel) + end if + select case (trim(adjustl(clevel))) + case ('SUMMARY') + isim_level = VSUMMARY + case ('DEBUG') + isim_level = VDEBUG + case default call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - case('-V', '--VERSION') - lstop = .TRUE. - write(line, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp - call write_message(line, skipbefore=1, skipafter=1) - case('-DEV', '--DEVELOP') - lstop = .TRUE. - write(line, '(2a,g0)') & - trim(adjustl(cexe)), ': develop version ', ltyp - call write_message(line, skipbefore=1, skipafter=1) - case('-C', '--COMPILER') - lstop = .TRUE. - call get_compiler(compiler) - write(line, '(2a,1x,a)') & - trim(adjustl(cexe)), ':', trim(adjustl(compiler)) - call write_message(line, skipbefore=1, skipafter=1) - case('-S', '--SILENT') - write(line, '(2a,1x,a)') & - trim(adjustl(cexe)), ':', 'all screen output sent to mfsim.stdout' - call write_message(line, skipbefore=1, skipafter=1) - case('-D', '--DISCLAIMER') - lstop = .TRUE. - call sim_message('', fmt=FMTDISCLAIMER) - case('-LIC', '--LICENSE') - lstop = .TRUE. - call sim_message('', fmt=FMTLICENSE) - case('-CO', '--COMPILER-OPT') - lstop = .TRUE. - call get_compile_options(coptions) - call write_message(coptions, skipbefore=1, skipafter=1) - case('-L', '--LEVEL') - if (len_trim(clevel) < 1) then - iarg = iarg + 1 - call get_command_argument(iarg, clevel) - call upcase(clevel) - end if - select case(trim(adjustl(clevel))) - case('SUMMARY') - isim_level = VSUMMARY - case('DEBUG') - isim_level = VDEBUG - case default - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal STDOUT level option -', & - trim(adjustl(clevel)) - call store_error(errmsg) - end select - ! - ! -- write message to stdout - write(line, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', 'stdout output level', & + write (errmsg, '(2a,1x,a)') & + trim(adjustl(cexe)), ': illegal STDOUT level option -', & trim(adjustl(clevel)) - call write_message(line, skipbefore=1, skipafter=1) - case('-M', '--MODE') - if (len_trim(cmode) < 1) then - iarg = iarg + 1 - call get_command_argument(iarg, cmode) - call upcase(cmode) - end if - select case(trim(adjustl(cmode))) - case('VALIDATE') - isim_mode = MVALIDATE - case default - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - errmsg = trim(adjustl(cexe)) // ': illegal MODFLOW 6 ' // & - 'simulation mode option - ' // trim(adjustl(cmode)) - call store_error(errmsg, terminate=.TRUE.) - end select - ! - ! -- write message to stdout - line = trim(adjustl(cexe)) // ': MODFLOW 6 simulation mode ' // & - trim(adjustl(cmode)) // '. Model input will be checked for all ' // & - 'stress periods but the matrix equations will not be ' // & - 'assembled or solved.' - call write_message(line, skipbefore=1, skipafter=1) + call store_error(errmsg) + end select + ! + ! -- write message to stdout + write (line, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', 'stdout output level', & + trim(adjustl(clevel)) + call write_message(line, skipbefore=1, skipafter=1) + case ('-M', '--MODE') + if (len_trim(cmode) < 1) then + iarg = iarg + 1 + call get_command_argument(iarg, cmode) + call upcase(cmode) + end if + select case (trim(adjustl(cmode))) + case ('VALIDATE') + isim_mode = MVALIDATE case default - lstop = .TRUE. call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal option -', trim(adjustl(tag)) + errmsg = trim(adjustl(cexe))//': illegal MODFLOW 6 '// & + 'simulation mode option - '//trim(adjustl(cmode)) call store_error(errmsg, terminate=.TRUE.) + end select + ! + ! -- write message to stdout + line = trim(adjustl(cexe))//': MODFLOW 6 simulation mode '// & + trim(adjustl(cmode))//'. Model input will be checked for all '// & + 'stress periods but the matrix equations will not be '// & + 'assembled or solved.' + call write_message(line, skipbefore=1, skipafter=1) + case default + lstop = .TRUE. + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + write (errmsg, '(2a,1x,a)') & + trim(adjustl(cexe)), ': illegal option -', trim(adjustl(tag)) + call store_error(errmsg, terminate=.TRUE.) end select end do ! ! -- check if simfile exists, only if the model should be run if (.not. lstop) then - inquire(file=trim(adjustl(simfile)), exist=lexist) + inquire (file=trim(adjustl(simfile)), exist=lexist) if (.NOT. lexist) then lstop = .TRUE. - write(errmsg, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(simfile)), & - 'is not present in working directory.' + write (errmsg, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', trim(adjustl(simfile)), & + 'is not present in working directory.' call store_error(errmsg, terminate=.TRUE.) end if end if @@ -260,7 +260,7 @@ subroutine GetCommandLineArguments() ! -- return return end subroutine GetCommandLineArguments - + !> @brief Write command line argument usage !! !! Subroutine to write usage information for command line arguments. @@ -268,48 +268,48 @@ end subroutine GetCommandLineArguments !< subroutine write_usage(header, cexe) ! -- dummy variables - character(len=*), intent(in) :: header !< header for usage - character(len=*), intent(in) :: cexe !< executable name + character(len=*), intent(in) :: header !< header for usage + character(len=*), intent(in) :: cexe !< executable name ! -- local variables character(len=LINELENGTH) :: line ! -- format - character(len=*), parameter :: OPTIONSFMT = & - "(/, & - &'Options GNU long option Meaning ',/, & - &' -h, -? --help Show this message',/, & - &' -v --version Display program version information.',/, & - &' -dev --develop Display program develop option mode.',/, & - &' -d --disclaimer Display program disclaimer.',/, & - &' -lic --license Display program license information.',/, & - &' -c --compiler Display compiler information.',/, & - &' -co --compiler-opt Display compiler options.',/, & - &' -s --silent All STDOUT to mfsim.stdout.',/, & - &' -l --level STDOUT output to screen based on .',/, & - &' =summary Limited output to STDOUT.',/, & - &' =debug Enhanced output to STDOUT.',/, & + character(len=*), parameter :: OPTIONSFMT = & + "(/,& + &'Options GNU long option Meaning ',/,& + &' -h, -? --help Show this message',/,& + &' -v --version Display program version information.',/,& + &' -dev --develop Display program develop option mode.',/,& + &' -d --disclaimer Display program disclaimer.',/,& + &' -lic --license Display program license information.',/,& + &' -c --compiler Display compiler information.',/,& + &' -co --compiler-opt Display compiler options.',/,& + &' -s --silent All STDOUT to mfsim.stdout.',/,"// & + "' -l --level STDOUT output to screen based on .',/,& + &' =summary Limited output to STDOUT.',/,& + &' =debug Enhanced output to STDOUT.',/,& &' -m --mode MODFLOW 6 simulation mode based on .',/,& - &' =validate Check model input for',/, & - &' errors but do not ',/, & - &' assemble or solve matrix ',/, & - &' equations or write ',/, & - &' solution output.',/, & - &' ',/, & - &'Bug reporting and contributions are welcome from the community. ',/, & - &'Questions can be asked on the issues page[1]. Before creating a new',/, & - &'issue, please take a moment to search and make sure a similar issue',/, & - &'does not already exist. If one does exist, you can comment (most',/, & - &'simply even with just :+1:) to show your support for that issue.',/, & - &' ',/, & + &' =validate Check model input for',/,& + &' errors but do not ',/,& + &' assemble or solve matrix ',/,& + &' equations or write ',/,& + &' solution output.',/,"// & + "' ',/,& + &'Bug reporting and contributions are welcome from the community. ',/,& + &'Questions can be asked on the issues page[1]. Before creating a new',/,& + &'issue, please take a moment to search and make sure a similar issue',/,& + &'does not already exist. If one does exist, you can comment (most',/,& + &'simply even with just :+1:) to show your support for that issue.',/,& + &' ',/,& &'[1] https://github.com/MODFLOW-USGS/modflow6/issues',/)" ! ! -- write command line usage information to the screen call sim_message(header) - write(line, '(a,1x,a,15x,a,2(1x,a),2a)') & - 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & + write (line, '(a,1x,a,15x,a,2(1x,a),2a)') & + 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & 'using "', trim(adjustl(simfile)), '"' call sim_message(line) - write(line, '(a,1x,a,1x,a,5x,a)') & - ' or:', cexe, '[options]', & + write (line, '(a,1x,a,1x,a,5x,a)') & + ' or:', cexe, '[options]', & 'retrieve program information' call sim_message(line) call sim_message('', fmt=OPTIONSFMT) @@ -317,5 +317,5 @@ subroutine write_usage(header, cexe) ! -- return return end subroutine write_usage - -end module CommandArguments \ No newline at end of file + +end module CommandArguments diff --git a/src/Utilities/compilerversion.F90 b/src/Utilities/compilerversion.F90 index 4f701dad114..5acfe4026a5 100644 --- a/src/Utilities/compilerversion.F90 +++ b/src/Utilities/compilerversion.F90 @@ -7,10 +7,10 @@ module CompilerVersion implicit none private ! -- compiler version - character(len=10) :: ccompiler !< compiler string - character(len=10) :: cversion !< compiler version string - character(len=20) :: cdate !< compilation date - integer(I4B) :: icompiler = CUNKNOWN !< compiler enum + character(len=10) :: ccompiler !< compiler string + character(len=10) :: cversion !< compiler version string + character(len=20) :: cdate !< compilation date + integer(I4B) :: icompiler = CUNKNOWN !< compiler enum public :: get_compiler, get_compile_date, get_compile_options contains @@ -34,7 +34,7 @@ subroutine get_compiler(txt) #endif #ifdef _CRAYFTN icompiler = CCRAYFTN - cdate = __DATE__ // ' ' // __TIME__ + cdate = __DATE__//' '//__TIME__ #endif ! ! -- set compiler strings @@ -60,7 +60,7 @@ end subroutine get_compiler !< subroutine get_compile_date(txt) ! -- dummy variables - character(len=20), intent(inout) :: txt !< compilation date + character(len=20), intent(inout) :: txt !< compilation date ! -- set variables #ifdef __GFORTRAN__ cdate = __DATE__//' '//__TIME__ @@ -69,7 +69,7 @@ subroutine get_compile_date(txt) cdate = __DATE__//' '//__TIME__ #endif #ifdef _CRAYFTN - cdate = __DATE__ // ' ' // __TIME__ + cdate = __DATE__//' '//__TIME__ #endif ! ! -- write compilation date string @@ -86,7 +86,7 @@ end subroutine get_compile_date !< subroutine get_compile_options(txt) ! -- dummy variables - character(len=LENBIGLINE), intent(inout) :: txt !< compilation options + character(len=LENBIGLINE), intent(inout) :: txt !< compilation options ! -- set variables ! ! -- set txt string diff --git a/src/Utilities/genericutils.f90 b/src/Utilities/genericutils.f90 index 188fc721614..549e3476d17 100644 --- a/src/Utilities/genericutils.f90 +++ b/src/Utilities/genericutils.f90 @@ -1,6 +1,6 @@ !> @brief This module contains generic utilties !! -!! This module contains generic utilities that have +!! This module contains generic utilities that have !! limited dependencies. !! !< @@ -11,33 +11,33 @@ module GenericUtilitiesModule LINELENGTH, LENHUGELINE, VSUMMARY use SimVariablesModule, only: istdout, isim_level ! - implicit none - + implicit none + private - + public :: sim_message public :: write_message public :: write_centered public :: is_same public :: stop_with_error - contains +contains !> @brief Write simulation message !! !! Subroutine to print message to user specified iunit or STDOUT based on level. !! !< - subroutine sim_message(message, iunit, fmt, level, & + subroutine sim_message(message, iunit, fmt, level, & skipbefore, skipafter, advance) ! -- dummy variables - character(len=*), intent(in) :: message !< message to write to iunit - integer(I4B), intent(in), optional :: iunit !< optional file unit to write the message to (default=stdout) - character(len=*), intent(in), optional :: fmt !< optional format to write the message (default='(a)') - integer(I4B), intent(in), optional :: level !< optional level for the message (default=summary) - integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) - integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) - logical(LGP), intent(in), optional :: advance !< optional boolean indicating if advancing output (default is .TRUE.) + character(len=*), intent(in) :: message !< message to write to iunit + integer(I4B), intent(in), optional :: iunit !< optional file unit to write the message to (default=stdout) + character(len=*), intent(in), optional :: fmt !< optional format to write the message (default='(a)') + integer(I4B), intent(in), optional :: level !< optional level for the message (default=summary) + integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) + integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) + logical(LGP), intent(in), optional :: advance !< optional boolean indicating if advancing output (default is .TRUE.) ! -- local variables character(len=3) :: cadvance integer(I4B) :: i @@ -84,7 +84,7 @@ subroutine sim_message(message, iunit, fmt, level, & ! -- write empty line before message if (present(skipbefore)) then do i = 1, skipbefore - write(iu, *) + write (iu, *) end do end if ! @@ -92,16 +92,16 @@ subroutine sim_message(message, iunit, fmt, level, & ! or equal the isim_level for the simulation if (ilevel <= isim_level) then if (ilen > 0) then - write(iu, trim(simfmt), advance=cadvance) message(1:ilen) + write (iu, trim(simfmt), advance=cadvance) message(1:ilen) else - write(iu, trim(simfmt), advance=cadvance) + write (iu, trim(simfmt), advance=cadvance) end if end if ! ! -- write empty line after message if (present(skipafter)) then do i = 1, skipafter - write(iu, *) + write (iu, *) end do end if ! @@ -111,7 +111,7 @@ end subroutine sim_message !> @brief Write messages !! - !! Subroutine that formats and writes a single message that + !! Subroutine that formats and writes a single message that !! may exceeed 78 characters in length. Messages longer than !! 78 characters are written across multiple lines. When a !! counter is passed in subsequent lines are indented. @@ -120,32 +120,32 @@ end subroutine sim_message subroutine write_message(message, icount, iwidth, iunit, level, & skipbefore, skipafter) ! -- dummy variables - character (len=*), intent(in) :: message !< message to be written - integer(I4B), intent(in), optional :: icount !< counter to prepended to the message - integer(I4B), intent(in), optional :: iwidth !< maximum width of the prepended counter - integer(I4B), intent(in), optional :: iunit !< the unit number to which the message is written - integer(I4B), intent(in), optional :: level !< level of message (VSUMMARY, VALL, VDEBUG) - integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) - integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) + character(len=*), intent(in) :: message !< message to be written + integer(I4B), intent(in), optional :: icount !< counter to prepended to the message + integer(I4B), intent(in), optional :: iwidth !< maximum width of the prepended counter + integer(I4B), intent(in), optional :: iunit !< the unit number to which the message is written + integer(I4B), intent(in), optional :: level !< level of message (VSUMMARY, VALL, VDEBUG) + integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) + integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) ! -- local variables - integer(I4B), parameter :: len_line=78 + integer(I4B), parameter :: len_line = 78 character(len=LENHUGELINE) :: amessage - character(len=len_line) :: line - character(len=16) :: cfmt - character(len=10) :: counter - character(len=5) :: fmt_first - character(len=20) :: fmt_cont - logical(LGP) :: include_counter - integer(I4B) :: isb - integer(I4B) :: isa - integer(I4B) :: jend - integer(I4B) :: len_str1 - integer(I4B) :: len_str2 - integer(I4B) :: len_message - integer(I4B) :: junit - integer(I4B) :: ilevel - integer(I4B) :: i - integer(I4B) :: j + character(len=len_line) :: line + character(len=16) :: cfmt + character(len=10) :: counter + character(len=5) :: fmt_first + character(len=20) :: fmt_cont + logical(LGP) :: include_counter + integer(I4B) :: isb + integer(I4B) :: isa + integer(I4B) :: jend + integer(I4B) :: len_str1 + integer(I4B) :: len_str2 + integer(I4B) :: len_message + integer(I4B) :: junit + integer(I4B) :: ilevel + integer(I4B) :: i + integer(I4B) :: j ! ! -- return if no message is passed if (len_trim(message) < 1) then @@ -162,10 +162,10 @@ subroutine write_message(message, icount, iwidth, iunit, level, & include_counter = .FALSE. junit = istdout j = 0 - ! + ! ! -- process optional dummy variables ! -- set the unit number - if(present(iunit))then + if (present(iunit)) then if (iunit > 0) then junit = iunit end if @@ -193,18 +193,18 @@ subroutine write_message(message, icount, iwidth, iunit, level, & end if ! ! -- create the counter to prepend to the start of the message, - ! formats, and variables used to create strings + ! formats, and variables used to create strings if (present(iwidth) .and. present(icount)) then include_counter = .TRUE. ! -- write counter - write(cfmt, '(A,I0,A)') '(1x,i', iwidth, ',".",1x)' - write(counter, cfmt) icount + write (cfmt, '(A,I0,A)') '(1x,i', iwidth, ',".",1x)' + write (counter, cfmt) icount ! -- calculate the length of the first and second string on a line len_str1 = len(trim(counter)) + 1 len_str2 = len_line - len_str1 ! -- write format for the continuation lines - write(fmt_cont, '(a,i0,a)') & - '(',len(trim(counter)) + 1, 'x,a)' + write (fmt_cont, '(a,i0,a)') & + '(', len(trim(counter)) + 1, 'x,a)' end if ! ! -- calculate the length of the message @@ -214,19 +214,19 @@ subroutine write_message(message, icount, iwidth, iunit, level, & 5 continue jend = j + len_str2 if (jend >= len_message) go to 100 - do i = jend, j+1, -1 - if (amessage(i:i).eq.' ') then + do i = jend, j + 1, -1 + if (amessage(i:i) .eq. ' ') then if (j == 0) then if (include_counter) then - line = counter(1:len_str1)//amessage(j+1:i) + line = counter(1:len_str1)//amessage(j + 1:i) else - line = amessage(j+1:i) + line = amessage(j + 1:i) end if call sim_message(line, iunit=junit, & fmt=fmt_first, level=ilevel, & skipbefore=isb) else - line = adjustl(amessage(j+1:i)) + line = adjustl(amessage(j + 1:i)) call sim_message(line, iunit=junit, & fmt=fmt_cont, level=ilevel) end if @@ -236,15 +236,15 @@ subroutine write_message(message, icount, iwidth, iunit, level, & end do if (j == 0) then if (include_counter) then - line = counter(1:len_str1)//amessage(j+1:jend) + line = counter(1:len_str1)//amessage(j + 1:jend) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) end if call sim_message(line, iunit=junit, & fmt=fmt_first, level=ilevel, & skipbefore=isb) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) call sim_message(line, iunit=junit, & fmt=fmt_cont, level=ilevel) end if @@ -256,15 +256,15 @@ subroutine write_message(message, icount, iwidth, iunit, level, & jend = len_message if (j == 0) then if (include_counter) then - line = counter(1:len_str1)//amessage(j+1:jend) + line = counter(1:len_str1)//amessage(j + 1:jend) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) end if call sim_message(line, iunit=junit, & fmt=fmt_first, level=ilevel, & skipbefore=isb, skipafter=isa) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) call sim_message(line, iunit=junit, fmt=fmt_cont, & level=ilevel, & skipafter=isa) @@ -276,15 +276,15 @@ end subroutine write_message !> @brief Write centered text !! - !! Subroutine to write text to unit iunit centered in width defined by linelen. + !! Subroutine to write text to unit iunit centered in width defined by linelen. !! Left-pad with blanks as needed. !! !< subroutine write_centered(text, linelen, iunit) ! -- dummy variables - character(len=*), intent(in) :: text !< message to write to iunit - integer(I4B), intent(in) :: linelen !< length of line to center text in - integer(I4B), intent(in), optional :: iunit !< optional file unit to write text (default=stdout) + character(len=*), intent(in) :: text !< message to write to iunit + integer(I4B), intent(in) :: linelen !< length of line to center text in + integer(I4B), intent(in), optional :: iunit !< optional file unit to write text (default=stdout) ! -- local variables character(len=linelen) :: line character(len=linelen) :: blank @@ -314,17 +314,17 @@ subroutine write_centered(text, linelen, iunit) 5 continue jend = j + linelen if (jend >= len_message) go to 100 - do i = jend, j+1, -1 - if (text(i:i).eq.' ') then - line = text(j+1:i) - ipad = ((linelen - len_trim(line)) / 2) + do i = jend, j + 1, -1 + if (text(i:i) .eq. ' ') then + line = text(j + 1:i) + ipad = ((linelen - len_trim(line)) / 2) call sim_message(blank(1:ipad)//line, iunit=iu) j = i go to 5 end if end do - line = text(j+1:jend) - ipad = ((linelen - len_trim(line)) / 2) + line = text(j + 1:jend) + ipad = ((linelen - len_trim(line)) / 2) call sim_message(blank(1:ipad)//line, iunit=iu) j = jend go to 5 @@ -332,28 +332,28 @@ subroutine write_centered(text, linelen, iunit) ! -- last piece of amessage to write to a line 100 continue jend = len_message - line = text(j+1:jend) - ipad = ((linelen - len_trim(line)) / 2) + line = text(j + 1:jend) + ipad = ((linelen - len_trim(line)) / 2) call sim_message(blank(1:ipad)//line, iunit=iu) end if ! ! -- return return end subroutine write_centered - + !> @brief Function to determine if two reals are the same !! - !! Function to evaluate if the difference between a and b are less than eps + !! Function to evaluate if the difference between a and b are less than eps !! (i.e. a and b are the same). !! !< function is_same(a, b, eps) result(lvalue) ! -- return variable - logical(LGP) :: lvalue !< boolean indicating if a and b are the same + logical(LGP) :: lvalue !< boolean indicating if a and b are the same ! -- dummy variables - real(DP), intent(in) :: a !< first number to evaluate - real(DP), intent(in) :: b !< second number to evaluate - real(DP), intent(in), optional :: eps !< optional maximum difference between a abd b (default=DSAME) + real(DP), intent(in) :: a !< first number to evaluate + real(DP), intent(in) :: b !< second number to evaluate + real(DP), intent(in), optional :: eps !< optional maximum difference between a abd b (default=DSAME) ! -- local variables real(DP) :: epsloc real(DP) :: denom @@ -364,7 +364,7 @@ function is_same(a, b, eps) result(lvalue) epsloc = eps else epsloc = DSAME - endif + end if lvalue = .FALSE. if (a == b) then lvalue = .TRUE. @@ -377,7 +377,7 @@ function is_same(a, b, eps) result(lvalue) denom = DPREC end if end if - rdiff = abs( (a - b) / denom ) + rdiff = abs((a - b) / denom) if (rdiff <= epsloc) then lvalue = .TRUE. end if @@ -394,7 +394,7 @@ end function is_same !< subroutine stop_with_error(ierr) ! -- dummy variables - integer(I4B), intent(in), optional :: ierr !< optional error code to return (default=0) + integer(I4B), intent(in), optional :: ierr !< optional error code to return (default=0) ! -- local variables integer(I4B) :: ireturn_err ! @@ -404,10 +404,10 @@ subroutine stop_with_error(ierr) else ireturn_err = 0 end if - + ! -- return the correct return code call exit(ireturn_err) - - end subroutine stop_with_error - end module GenericUtilitiesModule \ No newline at end of file + end subroutine stop_with_error + +end module GenericUtilitiesModule diff --git a/src/Utilities/kind.f90 b/src/Utilities/kind.f90 index cd372c384f8..60b355d0aa2 100644 --- a/src/Utilities/kind.f90 +++ b/src/Utilities/kind.f90 @@ -6,58 +6,58 @@ !! !< module KindModule - use, intrinsic:: iso_fortran_env, only: I4B => int32, & - I8B => int64, & - LGP => int32, & - DP => real64 - + use, intrinsic :: iso_fortran_env, only: I4B => int32, & + &I8B => int64, & + &LGP => int32, & + &DP => real64 + implicit none - public:: I4B, I8B, LGP, DP, write_kindinfo + public :: I4B, I8B, LGP, DP, write_kindinfo + +contains - contains - - !> @brief Write variable data types + !> @brief Write variable data types !! !! This subroutine writes the precision of logical, integer, long integer, !! and real data types used in MODFLOW 6. !! - !< - subroutine write_kindinfo(iout) - ! -- dummy variables - integer(I4B), intent(in) :: iout !< file unit to output kind variables - ! -- local variables - integer(LGP) :: ldum = 0 - integer(I4B) :: idum = 0 - integer(I8B) :: long_idum = 0 - integer(DP) :: irdum = 0 ! for bit size of real variables - real(DP) :: rdum = 0._DP - ! - ! -- write kind information - write(iout, '(/a)') 'Real Variables' - write(iout, '(2x,a,i0)') 'KIND: ', DP - write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', & - tiny(rdum) - write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) - write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum) - - write(iout, '(/a)') 'Integer Variables' - write(iout, '(2x,a,i0)') 'KIND: ', I4B - write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum) - - write(iout, '(/a)') 'Long Integer Variables' - write(iout, '(2x,a,i0)') 'KIND: ', I8B - write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum) - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum) - - write(iout, '(/a)') 'Logical Variables' - write(iout, '(2x,a,i0)') 'KIND: ', LGP - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum) - ! - ! -- Return - return - end subroutine write_kindinfo - + !< + subroutine write_kindinfo(iout) + ! -- dummy variables + integer(I4B), intent(in) :: iout !< file unit to output kind variables + ! -- local variables + integer(LGP) :: ldum = 0 + integer(I4B) :: idum = 0 + integer(I8B) :: long_idum = 0 + integer(DP) :: irdum = 0 ! for bit size of real variables + real(DP) :: rdum = 0._DP + ! + ! -- write kind information + write (iout, '(/a)') 'Real Variables' + write (iout, '(2x,a,i0)') 'KIND: ', DP + write (iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', & + tiny(rdum) + write (iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) + write (iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum) + + write (iout, '(/a)') 'Integer Variables' + write (iout, '(2x,a,i0)') 'KIND: ', I4B + write (iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum) + + write (iout, '(/a)') 'Long Integer Variables' + write (iout, '(2x,a,i0)') 'KIND: ', I8B + write (iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum) + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum) + + write (iout, '(/a)') 'Logical Variables' + write (iout, '(2x,a,i0)') 'KIND: ', LGP + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum) + ! + ! -- Return + return + end subroutine write_kindinfo + end module KindModule diff --git a/src/Utilities/sort.f90 b/src/Utilities/sort.f90 index 7fdc63e7292..4cc637a3511 100644 --- a/src/Utilities/sort.f90 +++ b/src/Utilities/sort.f90 @@ -11,514 +11,511 @@ module SortModule interface qsort module procedure qsort_int1d, qsort_dbl1d end interface - + interface unique_values module procedure unique_values_int1d, unique_values_dbl1d end interface - - contains - subroutine qsort_int1d(indx, v, reverse) +contains + subroutine qsort_int1d(indx, v, reverse) ! ************************************************************************** ! qsort -- quick sort that also includes an index number ! ************************************************************************** ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - ! -- dummy arguments - integer(I4B), dimension(:), intent(inout) :: indx - integer(I4B), dimension(:), intent(inout) :: v - logical, intent(in), optional :: reverse - ! -- local variables - logical :: lrev - integer(I4B), parameter :: nn=15 - integer(I4B), parameter :: nstack=50 - integer(I4B) :: nsize - integer(I4B) :: k - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jstack - integer(I4B) :: ileft - integer(I4B) :: iright - integer(I4B), dimension(nstack) :: istack - integer(I4B) :: iidx - integer(I4B) :: ia - integer(I4B) :: a - ! -- functions - ! -- code - ! - ! -- process optional dummy variables - if (present(reverse)) then - lrev = reverse + ! -- dummy arguments + integer(I4B), dimension(:), intent(inout) :: indx + integer(I4B), dimension(:), intent(inout) :: v + logical, intent(in), optional :: reverse + ! -- local variables + logical :: lrev + integer(I4B), parameter :: nn = 15 + integer(I4B), parameter :: nstack = 50 + integer(I4B) :: nsize + integer(I4B) :: k + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jstack + integer(I4B) :: ileft + integer(I4B) :: iright + integer(I4B), dimension(nstack) :: istack + integer(I4B) :: iidx + integer(I4B) :: ia + integer(I4B) :: a + ! -- functions + ! -- code + ! + ! -- process optional dummy variables + if (present(reverse)) then + lrev = reverse + else + lrev = .FALSE. + end if + ! + ! -- initialize variables + nsize = size(v) + jstack = 0 + ileft = 1 + iright = nsize + ! + ! -- perform quicksort + do + if (iright - ileft < nn) then + do j = (ileft + 1), iright + a = v(j) + iidx = indx(j) + do i = (j - 1), ileft, -1 + if (v(i) <= a) exit + v(i + 1) = v(i) + indx(i + 1) = indx(i) + end do + v(i + 1) = a + indx(i + 1) = iidx + end do + if (jstack == 0) return + iright = istack(jstack) + ileft = istack(jstack - 1) + jstack = jstack - 2 else - lrev = .FALSE. - endif - ! - ! -- initialize variables - nsize = size(v) - jstack = 0 - ileft = 1 - iright = nsize - ! - ! -- perform quicksort - do - if (iright - ileft < nn) then - do j = (ileft + 1), iright - a = v(j) - iidx = indx(j) - do i = (j - 1), ileft, -1 - if (v(i) <= a) exit - v(i+ 1) = v(i) - indx(i+ 1) = indx(i) - end do - v(i + 1) = a - indx(i + 1) = iidx + k = (ileft + iright) / 2 + call iswap(v(k), v(ileft + 1)) + call iswap(indx(k), indx(ileft + 1)) + if (v(ileft) > v(iright)) then + call iswap(v(ileft), v(iright)) + call iswap(indx(ileft), indx(iright)) + end if + if (v(ileft + 1) > v(iright)) then + call iswap(v(ileft + 1), v(iright)) + call iswap(indx(ileft + 1), indx(iright)) + end if + if (v(ileft) > v(ileft + 1)) then + call iswap(v(ileft), v(ileft + 1)) + call iswap(indx(ileft), indx(ileft + 1)) + end if + i = ileft + 1 + j = iright + a = v(ileft + 1) + ia = indx(ileft + 1) + do + do + i = i + 1 + if (v(i) >= a) then + exit + end if end do - if (jstack == 0) return - iright = istack(jstack) - ileft = istack(jstack - 1) - jstack = jstack - 2 - else - k = (ileft + iright)/2 - call iswap(v(k), v(ileft + 1)) - call iswap(indx(k), indx(ileft + 1)) - if (v(ileft) > v(iright)) then - call iswap(v(ileft), v(iright)) - call iswap(indx(ileft), indx(iright)) - end if - if (v(ileft + 1) > v(iright)) then - call iswap(v(ileft + 1), v(iright)) - call iswap(indx(ileft + 1), indx(iright)) - end if - if (v(ileft) > v(ileft + 1)) then - call iswap(v(ileft), v(ileft + 1)) - call iswap(indx(ileft), indx(ileft + 1)) - end if - i = ileft + 1 - j = iright - a = v(ileft + 1) - ia = indx(ileft + 1) do - do - i = i + 1 - if (v(i) >= a) then - exit - end if - end do - do - j = j - 1 - if (v(j) <= a) then - exit - end if - end do - if (j < i) then + j = j - 1 + if (v(j) <= a) then exit end if - call iswap(v(i), v(j)) - call iswap(indx(i), indx(j)) end do - v(ileft + 1) = v(j) - indx(ileft + 1) = indx(j) - v(j) = a - indx(j) = ia - jstack = jstack + 2 - if (jstack > nstack) then - write(errmsg,'(4x,a,3(1x,a))') & - 'JSTACK > NSTACK IN SortModule::qsort' - call store_error(errmsg, terminate=.TRUE.) - end if - if ((iright - i + 1) >= (j - 1)) then - istack(jstack) = iright - istack(jstack - 1) = i - iright = j - 1 - else - istack(jstack) = j - 1 - istack(jstack - 1) = ileft - ileft = i + if (j < i) then + exit end if - end if - end do - ! - ! -- reverse order of the heap index - if (lrev) then - j = nsize - do i = 1, nsize / 2 call iswap(v(i), v(j)) call iswap(indx(i), indx(j)) - j = j - 1 end do + v(ileft + 1) = v(j) + indx(ileft + 1) = indx(j) + v(j) = a + indx(j) = ia + jstack = jstack + 2 + if (jstack > nstack) then + write (errmsg, '(4x,a,3(1x,a))') & + 'JSTACK > NSTACK IN SortModule::qsort' + call store_error(errmsg, terminate=.TRUE.) + end if + if ((iright - i + 1) >= (j - 1)) then + istack(jstack) = iright + istack(jstack - 1) = i + iright = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = ileft + ileft = i + end if end if - ! - ! -- return - return - end subroutine qsort_int1d + end do + ! + ! -- reverse order of the heap index + if (lrev) then + j = nsize + do i = 1, nsize / 2 + call iswap(v(i), v(j)) + call iswap(indx(i), indx(j)) + j = j - 1 + end do + end if + ! + ! -- return + return + end subroutine qsort_int1d - subroutine qsort_dbl1d(indx, v, reverse) + subroutine qsort_dbl1d(indx, v, reverse) ! ************************************************************************** ! qsort -- quick sort that also includes an index number ! ************************************************************************** ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - ! -- dummy arguments - integer(I4B), dimension(:), intent(inout) :: indx - real(DP), dimension(:), intent(inout) :: v - logical, intent(in), optional :: reverse - ! -- local variables - logical :: lrev - integer(I4B), parameter :: nn=15 - integer(I4B), parameter :: nstack=50 - integer(I4B) :: nsize - integer(I4B) :: k - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jstack - integer(I4B) :: ileft - integer(I4B) :: iright - integer(I4B), dimension(nstack) :: istack - integer(I4B) :: iidx - integer(I4B) :: ia - real(DP) :: a - ! -- functions - ! -- code - ! - ! -- process optional dummy variables - if (present(reverse)) then - lrev = reverse + ! -- dummy arguments + integer(I4B), dimension(:), intent(inout) :: indx + real(DP), dimension(:), intent(inout) :: v + logical, intent(in), optional :: reverse + ! -- local variables + logical :: lrev + integer(I4B), parameter :: nn = 15 + integer(I4B), parameter :: nstack = 50 + integer(I4B) :: nsize + integer(I4B) :: k + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jstack + integer(I4B) :: ileft + integer(I4B) :: iright + integer(I4B), dimension(nstack) :: istack + integer(I4B) :: iidx + integer(I4B) :: ia + real(DP) :: a + ! -- functions + ! -- code + ! + ! -- process optional dummy variables + if (present(reverse)) then + lrev = reverse + else + lrev = .FALSE. + end if + ! + ! -- initialize variables + nsize = size(v) + jstack = 0 + ileft = 1 + iright = nsize + ! + ! -- perform quicksort + do + if (iright - ileft < nn) then + do j = (ileft + 1), iright + a = v(j) + iidx = indx(j) + do i = (j - 1), ileft, -1 + if (v(i) <= a) exit + v(i + 1) = v(i) + indx(i + 1) = indx(i) + end do + v(i + 1) = a + indx(i + 1) = iidx + end do + if (jstack == 0) return + iright = istack(jstack) + ileft = istack(jstack - 1) + jstack = jstack - 2 else - lrev = .FALSE. - endif - ! - ! -- initialize variables - nsize = size(v) - jstack = 0 - ileft = 1 - iright = nsize - ! - ! -- perform quicksort - do - if (iright - ileft < nn) then - do j = (ileft + 1), iright - a = v(j) - iidx = indx(j) - do i = (j - 1), ileft, -1 - if (v(i) <= a) exit - v(i+ 1) = v(i) - indx(i+ 1) = indx(i) - end do - v(i + 1) = a - indx(i + 1) = iidx + k = (ileft + iright) / 2 + call rswap(v(k), v(ileft + 1)) + call iswap(indx(k), indx(ileft + 1)) + if (v(ileft) > v(iright)) then + call rswap(v(ileft), v(iright)) + call iswap(indx(ileft), indx(iright)) + end if + if (v(ileft + 1) > v(iright)) then + call rswap(v(ileft + 1), v(iright)) + call iswap(indx(ileft + 1), indx(iright)) + end if + if (v(ileft) > v(ileft + 1)) then + call rswap(v(ileft), v(ileft + 1)) + call iswap(indx(ileft), indx(ileft + 1)) + end if + i = ileft + 1 + j = iright + a = v(ileft + 1) + ia = indx(ileft + 1) + do + do + i = i + 1 + if (v(i) >= a) then + exit + end if end do - if (jstack == 0) return - iright = istack(jstack) - ileft = istack(jstack - 1) - jstack = jstack - 2 - else - k = (ileft + iright)/2 - call rswap(v(k), v(ileft + 1)) - call iswap(indx(k), indx(ileft + 1)) - if (v(ileft) > v(iright)) then - call rswap(v(ileft), v(iright)) - call iswap(indx(ileft), indx(iright)) - end if - if (v(ileft + 1) > v(iright)) then - call rswap(v(ileft + 1), v(iright)) - call iswap(indx(ileft + 1), indx(iright)) - end if - if (v(ileft) > v(ileft + 1)) then - call rswap(v(ileft), v(ileft + 1)) - call iswap(indx(ileft), indx(ileft + 1)) - end if - i = ileft + 1 - j = iright - a = v(ileft + 1) - ia = indx(ileft + 1) do - do - i = i + 1 - if (v(i) >= a) then - exit - end if - end do - do - j = j - 1 - if (v(j) <= a) then - exit - end if - end do - if (j < i) then + j = j - 1 + if (v(j) <= a) then exit end if - call rswap(v(i), v(j)) - call iswap(indx(i), indx(j)) end do - v(ileft + 1) = v(j) - indx(ileft + 1) = indx(j) - v(j) = a - indx(j) = ia - jstack = jstack + 2 - if (jstack > nstack) then - write(errmsg,'(4x,a,3(1x,a))') & - 'JSTACK > NSTACK IN SortModule::qsort' - call store_error(errmsg, terminate=.TRUE.) - end if - if ((iright - i + 1) >= (j - 1)) then - istack(jstack) = iright - istack(jstack - 1) = i - iright = j - 1 - else - istack(jstack) = j - 1 - istack(jstack - 1) = ileft - ileft = i + if (j < i) then + exit end if - end if - end do - ! - ! -- reverse order of the heap index - if (lrev) then - j = nsize - do i = 1, nsize / 2 call rswap(v(i), v(j)) call iswap(indx(i), indx(j)) - j = j - 1 end do + v(ileft + 1) = v(j) + indx(ileft + 1) = indx(j) + v(j) = a + indx(j) = ia + jstack = jstack + 2 + if (jstack > nstack) then + write (errmsg, '(4x,a,3(1x,a))') & + 'JSTACK > NSTACK IN SortModule::qsort' + call store_error(errmsg, terminate=.TRUE.) + end if + if ((iright - i + 1) >= (j - 1)) then + istack(jstack) = iright + istack(jstack - 1) = i + iright = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = ileft + ileft = i + end if end if - ! - ! -- return - return - end subroutine qsort_dbl1d - - subroutine unique_values_int1d(a, b) - ! - dummy arguments - integer(I4B), dimension(:), allocatable, intent(in) :: a - integer(I4B), dimension(:), allocatable, intent(inout) :: b - ! -- local variables - integer(I4B) :: count - integer(I4B) :: n - integer(I4B), dimension(:), allocatable :: indxarr - integer(I4B), dimension(:), allocatable :: tarr - ! -- functions - ! -- code - ! - ! -- allocate tarr and create idxarr - allocate(tarr(size(a))) - allocate(indxarr(size(a))) - ! - ! -- fill tarr with a and create index - do n = 1, size(a) - tarr(n) = a(n) - indxarr(n) = n + end do + ! + ! -- reverse order of the heap index + if (lrev) then + j = nsize + do i = 1, nsize / 2 + call rswap(v(i), v(j)) + call iswap(indx(i), indx(j)) + j = j - 1 end do - ! - ! -- sort a in increasing order - call qsort(indxarr, tarr, reverse=.TRUE.) - ! - ! -- determine the number of unique values - count = 1 - do n = 2, size(tarr) - if (tarr(n) > tarr(n-1)) count = count + 1 - end do - ! - ! -- allocate b for unique values - if (allocated(b)) then - deallocate(b) + end if + ! + ! -- return + return + end subroutine qsort_dbl1d + + subroutine unique_values_int1d(a, b) + ! - dummy arguments + integer(I4B), dimension(:), allocatable, intent(in) :: a + integer(I4B), dimension(:), allocatable, intent(inout) :: b + ! -- local variables + integer(I4B) :: count + integer(I4B) :: n + integer(I4B), dimension(:), allocatable :: indxarr + integer(I4B), dimension(:), allocatable :: tarr + ! -- functions + ! -- code + ! + ! -- allocate tarr and create idxarr + allocate (tarr(size(a))) + allocate (indxarr(size(a))) + ! + ! -- fill tarr with a and create index + do n = 1, size(a) + tarr(n) = a(n) + indxarr(n) = n + end do + ! + ! -- sort a in increasing order + call qsort(indxarr, tarr, reverse=.TRUE.) + ! + ! -- determine the number of unique values + count = 1 + do n = 2, size(tarr) + if (tarr(n) > tarr(n - 1)) count = count + 1 + end do + ! + ! -- allocate b for unique values + if (allocated(b)) then + deallocate (b) + end if + allocate (b(count)) + ! + ! -- fill b with unique values + b(1) = tarr(1) + count = 1 + do n = 2, size(a) + if (tarr(n) > b(count)) then + count = count + 1 + b(count) = tarr(n) end if - allocate(b(count)) - ! - ! -- fill b with unique values - b(1) = tarr(1) - count = 1 - do n = 2, size(a) - if (tarr(n) > b(count)) then - count = count + 1 - b(count) = tarr(n) - end if - end do - ! - ! -- allocate tarr and create idxarr - deallocate(tarr) - deallocate(indxarr) - ! - ! -- return - return - end subroutine unique_values_int1d - - subroutine unique_values_dbl1d(a, b) - ! - dummy arguments - real(DP), dimension(:), allocatable, intent(in) :: a - real(DP), dimension(:), allocatable, intent(inout) :: b - ! -- local variables - integer(I4B) :: count - integer(I4B) :: n - integer(I4B), dimension(:), allocatable :: indxarr - real(DP), dimension(:), allocatable :: tarr - ! -- functions - ! -- code - ! - ! -- allocate tarr and create idxarr - allocate(tarr(size(a))) - allocate(indxarr(size(a))) - ! - ! -- fill tarr with a and create index - do n = 1, size(a) - tarr(n) = a(n) - indxarr(n) = n - end do - ! - ! -- sort a in increasing order - call qsort(indxarr, tarr, reverse=.TRUE.) - ! - ! -- determine the number of unique values - count = 1 - do n = 2, size(tarr) - if (tarr(n) > tarr(n-1)) count = count + 1 - end do - ! - ! -- allocate b for unique values - if (allocated(b)) then - deallocate(b) + end do + ! + ! -- allocate tarr and create idxarr + deallocate (tarr) + deallocate (indxarr) + ! + ! -- return + return + end subroutine unique_values_int1d + + subroutine unique_values_dbl1d(a, b) + ! - dummy arguments + real(DP), dimension(:), allocatable, intent(in) :: a + real(DP), dimension(:), allocatable, intent(inout) :: b + ! -- local variables + integer(I4B) :: count + integer(I4B) :: n + integer(I4B), dimension(:), allocatable :: indxarr + real(DP), dimension(:), allocatable :: tarr + ! -- functions + ! -- code + ! + ! -- allocate tarr and create idxarr + allocate (tarr(size(a))) + allocate (indxarr(size(a))) + ! + ! -- fill tarr with a and create index + do n = 1, size(a) + tarr(n) = a(n) + indxarr(n) = n + end do + ! + ! -- sort a in increasing order + call qsort(indxarr, tarr, reverse=.TRUE.) + ! + ! -- determine the number of unique values + count = 1 + do n = 2, size(tarr) + if (tarr(n) > tarr(n - 1)) count = count + 1 + end do + ! + ! -- allocate b for unique values + if (allocated(b)) then + deallocate (b) + end if + allocate (b(count)) + ! + ! -- fill b with unique values + b(1) = tarr(1) + count = 1 + do n = 2, size(a) + if (tarr(n) > b(count)) then + count = count + 1 + b(count) = tarr(n) end if - allocate(b(count)) - ! - ! -- fill b with unique values - b(1) = tarr(1) - count = 1 - do n = 2, size(a) - if (tarr(n) > b(count)) then - count = count + 1 - b(count) = tarr(n) - end if - end do - ! - ! -- allocate tarr and create idxarr - deallocate(tarr) - deallocate(indxarr) - ! - ! -- return - return - end subroutine unique_values_dbl1d - - subroutine selectn(indx, v, reverse) + end do + ! + ! -- allocate tarr and create idxarr + deallocate (tarr) + deallocate (indxarr) + ! + ! -- return + return + end subroutine unique_values_dbl1d + + subroutine selectn(indx, v, reverse) ! ************************************************************************** ! selectn -- heap selection ! ************************************************************************** ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - ! -- dummy arguments - integer(I4B), dimension(:), intent(inout) :: indx - real(DP), dimension(:), intent(inout) :: v - logical, intent(in), optional :: reverse - ! -- local variables - logical :: lrev - integer(I4B) :: nsizei - integer(I4B) :: nsizev - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: n - !integer(I4B) :: iidx - real(DP), dimension(:), allocatable :: vv - ! -- functions - ! -- code - ! - ! -- process optional dummy variables - if (present(reverse)) then - lrev = reverse - else - lrev = .FALSE. - endif - ! - ! -- initialize heap - nsizev = size(v) - nsizei = min(nsizev, size(indx)) - allocate(vv(nsizei)) - ! - ! -- initialize heap index (indx) and heap (vv) - do n = 1, nsizei - vv(n) = v(n) - indx(n) = n - end do - ! - ! -- initial sort - call qsort(indx, vv) - ! - ! -- evaluate the remaining elements in v - do i = nsizei+1, nsizev - ! - ! -- put the current value on the heap - if (v(i) > vv(1)) then - vv(1) = v(i) - indx(1) = i - j = 1 - do - k = 2 * j - if (k > nsizei) then - exit - end if - if (k /= nsizei) then - if (vv(k) > vv(k+1)) then - k = k + 1 - end if - end if - if (vv(j) <= vv(k)) then - exit + ! -- dummy arguments + integer(I4B), dimension(:), intent(inout) :: indx + real(DP), dimension(:), intent(inout) :: v + logical, intent(in), optional :: reverse + ! -- local variables + logical :: lrev + integer(I4B) :: nsizei + integer(I4B) :: nsizev + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: n + !integer(I4B) :: iidx + real(DP), dimension(:), allocatable :: vv + ! -- functions + ! -- code + ! + ! -- process optional dummy variables + if (present(reverse)) then + lrev = reverse + else + lrev = .FALSE. + end if + ! + ! -- initialize heap + nsizev = size(v) + nsizei = min(nsizev, size(indx)) + allocate (vv(nsizei)) + ! + ! -- initialize heap index (indx) and heap (vv) + do n = 1, nsizei + vv(n) = v(n) + indx(n) = n + end do + ! + ! -- initial sort + call qsort(indx, vv) + ! + ! -- evaluate the remaining elements in v + do i = nsizei + 1, nsizev + ! + ! -- put the current value on the heap + if (v(i) > vv(1)) then + vv(1) = v(i) + indx(1) = i + j = 1 + do + k = 2 * j + if (k > nsizei) then + exit + end if + if (k /= nsizei) then + if (vv(k) > vv(k + 1)) then + k = k + 1 end if - call rswap(vv(k), vv(j)) - call iswap(indx(k), indx(j)) - j = k - end do - end if - end do - ! - ! -- final sort - call qsort(indx, vv) - ! - ! -- reverse order of the heap index - if (lrev) then - j = nsizei - do i = 1, nsizei / 2 - call iswap(indx(i), indx(j)) - j = j - 1 + end if + if (vv(j) <= vv(k)) then + exit + end if + call rswap(vv(k), vv(j)) + call iswap(indx(k), indx(j)) + j = k end do end if - ! - ! -- return - return - end subroutine selectn + end do + ! + ! -- final sort + call qsort(indx, vv) + ! + ! -- reverse order of the heap index + if (lrev) then + j = nsizei + do i = 1, nsizei / 2 + call iswap(indx(i), indx(j)) + j = j - 1 + end do + end if + ! + ! -- return + return + end subroutine selectn - subroutine rswap(a, b) - ! -- dummy arguments - real(DP), intent(inout) :: a - real(DP), intent(inout) :: b - ! -- local variables - real(DP) :: d - ! -- functions - ! -- code - d = a - a = b - b = d - ! - ! -- return - return - end subroutine rswap + subroutine rswap(a, b) + ! -- dummy arguments + real(DP), intent(inout) :: a + real(DP), intent(inout) :: b + ! -- local variables + real(DP) :: d + ! -- functions + ! -- code + d = a + a = b + b = d + ! + ! -- return + return + end subroutine rswap + + subroutine iswap(ia, ib) + ! -- dummy arguments + integer(I4B), intent(inout) :: ia + integer(I4B), intent(inout) :: ib + ! -- local variables + integer(I4B) :: id + ! -- functions + ! -- code + id = ia + ia = ib + ib = id + ! + ! -- return + return + end subroutine iswap - subroutine iswap(ia, ib) - ! -- dummy arguments - integer(I4B), intent(inout) :: ia - integer(I4B), intent(inout) :: ib - ! -- local variables - integer(I4B) :: id - ! -- functions - ! -- code - id = ia - ia = ib - ib = id - ! - ! -- return - return - end subroutine iswap - - - end module SortModule diff --git a/src/Utilities/version.f90 b/src/Utilities/version.f90 index f9078d34409..95fd8e01ec5 100644 --- a/src/Utilities/version.f90 +++ b/src/Utilities/version.f90 @@ -13,141 +13,141 @@ module VersionModule use CompilerVersion, only: get_compiler, get_compile_options implicit none public - ! -- modflow 6 version - integer(I4B), parameter :: IDEVELOPMODE = 1 - character(len=*), parameter :: VERSIONNUMBER = '6.4.0' - character(len=*), parameter :: VERSIONTAG = ' release candidate 03/04/2022' - character(len=40), parameter :: VERSION = VERSIONNUMBER//VERSIONTAG - character(len=10), parameter :: MFVNAM = ' 6' - character(len=*), parameter :: MFTITLE = & - 'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL' - character(len=*), parameter :: FMTTITLE = & - "(/,34X,'MODFLOW',A,/, & - &16X,'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL', & - &/,23X,'Version ',A/)" - ! -- license for MODFLOW and libraries - character(len=*), parameter :: FMTLICENSE = & - "(/, & - &'As a work of the United States Government, this USGS product is ',/, & - &'in the public domain within the United States. You can copy, ',/, & - &'modify, distribute, and perform the work, even for commercial ',/, & - &'purposes, all without asking permission. Additionally, USGS ',/, & - &'waives copyright and related rights in the work worldwide ',/, & - &'through CC0 1.0 Universal Public Domain Dedication ',/, & - &'(https://creativecommons.org/publicdomain/zero/1.0/).',//, & - &'The following GNU Lesser General Public License (LGPL) libraries',/, & - &'are used in this USGS product:',//, & - &' SPARSKIT version 2.0',/, & - &' ilut, luson, and qsplit ',/, & - &' (https://www-users.cse.umn.edu/~saad/software/SPARSKIT/)',//, & - &' RCM - Reverse Cuthill McKee Ordering',/, & - &' (https://people.math.sc.edu/Burkardt/f_src/rcm/rcm.html)',//, & - &' BLAS - Basic Linear Algebra Subprograms Level 1',/, & - &' (https://people.math.sc.edu/Burkardt/f_src/blas1_d/', & - &'blas1_d.html)',//, & - &' SPARSEKIT - Sparse Matrix Utility Package',/, & - &' amux, dperm, dvperm, rperm, and cperm',/, & - &' (https://people.sc.fsu.edu/~jburkardt/f77_src/sparsekit/', & - &'sparsekit.html)',//, & - &'The following BSD-3 License libraries are used in this USGS product:',//, & - &' Modern Fortran DAG Library',/, & - &' Copyright (c) 2018, Jacob Williams',/, & - &' All rights reserved.',/, & - &' (https://github.com/jacobwilliams/daglib)',/ & - &)" - ! -- disclaimer must be appropriate for version (release or release candidate) - character(len=*), parameter :: FMTDISCLAIMER = & - "(/, & - &'This software is preliminary or provisional and is subject to ',/, & - &'revision. It is being provided to meet the need for timely best ',/, & - &'science. The software has not received final approval by the U.S. ',/, & - &'Geological Survey (USGS). No warranty, expressed or implied, is made ',/, & - &'by the USGS or the U.S. Government as to the functionality of the ',/, & - &'software and related material nor shall the fact of release ',/, & - &'constitute any such warranty. The software is provided on the ',/, & + ! -- modflow 6 version + integer(I4B), parameter :: IDEVELOPMODE = 1 + character(len=*), parameter :: VERSIONNUMBER = '6.4.0' + character(len=*), parameter :: VERSIONTAG = ' release candidate 03/04/2022' + character(len=40), parameter :: VERSION = VERSIONNUMBER//VERSIONTAG + character(len=10), parameter :: MFVNAM = ' 6' + character(len=*), parameter :: MFTITLE = & + &'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL' + character(len=*), parameter :: FMTTITLE = & + "(/,34X,'MODFLOW',A,/,& + &16X,'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL',& + &/,23X,'Version ',A/)" + ! -- license for MODFLOW and libraries + character(len=*), parameter :: FMTLICENSE = & + "(/,& + &'As a work of the United States Government, this USGS product is ',/,& + &'in the public domain within the United States. You can copy, ',/,& + &'modify, distribute, and perform the work, even for commercial ',/,& + &'purposes, all without asking permission. Additionally, USGS ',/,& + &'waives copyright and related rights in the work worldwide ',/,& + &'through CC0 1.0 Universal Public Domain Dedication ',/,& + &'(https://creativecommons.org/publicdomain/zero/1.0/).',//,& + &'The following GNU Lesser General Public License (LGPL) libraries',/,& + &'are used in this USGS product:',//,"// & + "' SPARSKIT version 2.0',/,& + &' ilut, luson, and qsplit ',/,& + &' (https://www-users.cse.umn.edu/~saad/software/SPARSKIT/)',//,& + &' RCM - Reverse Cuthill McKee Ordering',/,& + &' (https://people.math.sc.edu/Burkardt/f_src/rcm/rcm.html)',//,& + &' BLAS - Basic Linear Algebra Subprograms Level 1',/,& + &' (https://people.math.sc.edu/Burkardt/f_src/blas1_d/',& + &'blas1_d.html)',//,"// & + "' SPARSEKIT - Sparse Matrix Utility Package',/,& + &' amux, dperm, dvperm, rperm, and cperm',/,& + &' (https://people.sc.fsu.edu/~jburkardt/f77_src/sparsekit/',& + &'sparsekit.html)',//,& + &'The following BSD-3 License libraries are used in this USGS product:',//,& + &' Modern Fortran DAG Library',/,& + &' Copyright (c) 2018, Jacob Williams',/,& + &' All rights reserved.',/,& + &' (https://github.com/jacobwilliams/daglib)',/& + &)" + ! -- disclaimer must be appropriate for version (release or release candidate) + character(len=*), parameter :: FMTDISCLAIMER = & + "(/,& + &'This software is preliminary or provisional and is subject to ',/,& + &'revision. It is being provided to meet the need for timely best ',/,& + &'science. The software has not received final approval by the U.S. ',/,& + &'Geological Survey (USGS). No warranty, expressed or implied, is made ',/,& + &'by the USGS or the U.S. Government as to the functionality of the ',/,& + &'software and related material nor shall the fact of release ',/,& + &'constitute any such warranty. The software is provided on the ',/,& &'condition that neither the USGS nor the U.S. Government shall be held ',/,& - &'liable for any damages resulting from the authorized or unauthorized ',/, & + &'liable for any damages resulting from the authorized or unauthorized ',/,& &'use of the software.',/)" - contains +contains - !> @ brief Write program header + !> @ brief Write program header !! !! Write header for program to the program listing file. !! - !< - subroutine write_listfile_header(iout, cmodel_type, write_sys_command, & - write_kind_info) - ! -- dummy variables - integer(I4B), intent(in) :: iout !< program listing file - character(len=*), intent(in), optional :: cmodel_type !< optional model type string - logical(LGP), intent(in), optional :: write_sys_command !< boolean indicating if the system command should be written - logical(LGP), intent(in), optional :: write_kind_info !< boolean indicating in program data types should be written - ! -- local variables - character(len=LENBIGLINE) :: syscmd - character(len=LENBIGLINE) :: compiler - character(len=LENBIGLINE) :: compiler_options - integer(I4B) :: iheader_width = 80 - logical(LGP) :: wki - logical(LGP) :: wsc - ! - ! -- Write title to list file - call write_centered('MODFLOW'//MFVNAM, iheader_width, iunit=iout) - call write_centered(MFTITLE, iheader_width, iunit=iout) - ! - ! -- Write model type to list file - if (present(cmodel_type)) then - call write_centered(cmodel_type, iheader_width, iunit=iout) - end if - ! - ! -- Write version - call write_centered('VERSION '//VERSION, iheader_width, iunit=iout) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) then - call write_centered('***DEVELOP MODE***', iheader_width, iunit=iout) - end if - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', iheader_width, iunit=iout) - call write_centered(trim(adjustl(compiler)), iheader_width, iunit=iout) - ! - ! -- Write disclaimer - write(iout, FMTDISCLAIMER) - ! - ! -- Write license information - if (iout /= istdout) then - write(iout, FMTLICENSE) - end if - ! - ! -- write compiler options - if (iout /= istdout) then - call get_compile_options(compiler_options) - call write_message(compiler_options, iunit=iout) - end if - ! - ! -- Write the system command used to initiate simulation - wsc = .true. - if (present(write_sys_command)) wsc = write_sys_command - if (wsc) then - call GET_COMMAND(syscmd) - write(iout, '(/,a,/,a)') 'System command used to initiate simulation:', & - trim(syscmd) - end if - ! - ! -- Write precision of real variables - wki = .true. - if (present(write_kind_info)) wki = write_kind_info - if (wki) then - write(iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' - call write_kindinfo(iout) - end if - write(iout, *) - ! - ! -- return - return - end subroutine write_listfile_header + !< + subroutine write_listfile_header(iout, cmodel_type, write_sys_command, & + write_kind_info) + ! -- dummy variables + integer(I4B), intent(in) :: iout !< program listing file + character(len=*), intent(in), optional :: cmodel_type !< optional model type string + logical(LGP), intent(in), optional :: write_sys_command !< boolean indicating if the system command should be written + logical(LGP), intent(in), optional :: write_kind_info !< boolean indicating in program data types should be written + ! -- local variables + character(len=LENBIGLINE) :: syscmd + character(len=LENBIGLINE) :: compiler + character(len=LENBIGLINE) :: compiler_options + integer(I4B) :: iheader_width = 80 + logical(LGP) :: wki + logical(LGP) :: wsc + ! + ! -- Write title to list file + call write_centered('MODFLOW'//MFVNAM, iheader_width, iunit=iout) + call write_centered(MFTITLE, iheader_width, iunit=iout) + ! + ! -- Write model type to list file + if (present(cmodel_type)) then + call write_centered(cmodel_type, iheader_width, iunit=iout) + end if + ! + ! -- Write version + call write_centered('VERSION '//VERSION, iheader_width, iunit=iout) + ! + ! -- Write if develop mode + if (IDEVELOPMODE == 1) then + call write_centered('***DEVELOP MODE***', iheader_width, iunit=iout) + end if + ! + ! -- Write compiler version + call get_compiler(compiler) + call write_centered(' ', iheader_width, iunit=iout) + call write_centered(trim(adjustl(compiler)), iheader_width, iunit=iout) + ! + ! -- Write disclaimer + write (iout, FMTDISCLAIMER) + ! + ! -- Write license information + if (iout /= istdout) then + write (iout, FMTLICENSE) + end if + ! + ! -- write compiler options + if (iout /= istdout) then + call get_compile_options(compiler_options) + call write_message(compiler_options, iunit=iout) + end if + ! + ! -- Write the system command used to initiate simulation + wsc = .true. + if (present(write_sys_command)) wsc = write_sys_command + if (wsc) then + call GET_COMMAND(syscmd) + write (iout, '(/,a,/,a)') & + 'System command used to initiate simulation:', trim(syscmd) + end if + ! + ! -- Write precision of real variables + wki = .true. + if (present(write_kind_info)) wki = write_kind_info + if (wki) then + write (iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' + call write_kindinfo(iout) + end if + write (iout, *) + ! + ! -- return + return + end subroutine write_listfile_header end module VersionModule diff --git a/src/mf6.f90 b/src/mf6.f90 index 2b705c96ed5..94a2818ac87 100644 --- a/src/mf6.f90 +++ b/src/mf6.f90 @@ -9,6 +9,5 @@ program mf6 ! ! -- run call Mf6Run() - + end program - \ No newline at end of file diff --git a/src/mf6core.f90 b/src/mf6core.f90 index 6312fd05cd8..988c3b651bd 100644 --- a/src/mf6core.f90 +++ b/src/mf6core.f90 @@ -5,344 +5,344 @@ !! of MODFLOW 6. !! !< -module Mf6CoreModule - use KindModule, only: I4B, LGP - use ListsModule, only: basesolutionlist, solutiongrouplist, & - basemodellist, baseexchangelist, & - baseconnectionlist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use SpatialModelConnectionModule, only: SpatialModelConnectionType, & +module Mf6CoreModule + use KindModule, only: I4B, LGP + use ListsModule, only: basesolutionlist, solutiongrouplist, & + basemodellist, baseexchangelist, & + baseconnectionlist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use SpatialModelConnectionModule, only: SpatialModelConnectionType, & GetSpatialModelConnectionFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - implicit none + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList + implicit none - contains - - !> @brief Main controller +contains + + !> @brief Main controller !! !! This subroutine is the main controller for MODFLOW 6. !! - !< - subroutine Mf6Run - ! -- modules - use CommandArguments, only: GetCommandLineArguments - use TdisModule, only: totim, totalsimtime - use KindModule, only: DP - ! -- local - logical(LGP) :: hasConverged - ! - ! -- parse any command line arguments - call GetCommandLineArguments() - ! - ! initialize simulation - call Mf6Initialize() - ! - ! -- time loop - do while (totim < totalsimtime) - - ! perform a time step - hasConverged = Mf6Update() - - ! if not converged, break - if (.not. hasConverged) exit - - end do - ! - ! -- finalize simulation - call Mf6Finalize() - - end subroutine Mf6Run - - !> @brief Initialize a simulation + !< + subroutine Mf6Run + ! -- modules + use CommandArguments, only: GetCommandLineArguments + use TdisModule, only: totim, totalsimtime + use KindModule, only: DP + ! -- local + logical(LGP) :: hasConverged + ! + ! -- parse any command line arguments + call GetCommandLineArguments() + ! + ! initialize simulation + call Mf6Initialize() + ! + ! -- time loop + do while (totim < totalsimtime) + + ! perform a time step + hasConverged = Mf6Update() + + ! if not converged, break + if (.not. hasConverged) exit + + end do + ! + ! -- finalize simulation + call Mf6Finalize() + + end subroutine Mf6Run + + !> @brief Initialize a simulation !! !! This subroutine initializes a MODFLOW 6 simulation. The subroutine: !! - creates the simulation !! - defines !! - allocates and reads static data !! - !< - subroutine Mf6Initialize() - ! -- modules - use SimulationCreateModule, only: simulation_cr - ! - ! -- print banner and info to screen - call printInfo() - - ! -- create - call simulation_cr() - - ! -- define - call simulation_df() - - ! -- allocate and read - call simulation_ar() - - end subroutine Mf6Initialize - - !> @brief Run a time step + !< + subroutine Mf6Initialize() + ! -- modules + use SimulationCreateModule, only: simulation_cr + ! + ! -- print banner and info to screen + call printInfo() + + ! -- create + call simulation_cr() + + ! -- define + call simulation_df() + + ! -- allocate and read + call simulation_ar() + + end subroutine Mf6Initialize + + !> @brief Run a time step !! !! This function runs a single time step to completion. !! !! @return hasConverged boolean indicating if convergence was achieved for the time step !! - !< - function Mf6Update() result(hasConverged) - ! -- return variable - logical(LGP) :: hasConverged - ! - ! -- prepare timestep - call Mf6PrepareTimestep() - ! - ! -- do timestep - call Mf6DoTimestep() - ! - ! -- after timestep - hasConverged = Mf6FinalizeTimestep() - ! - end function Mf6Update - - !> @brief Finalize the simulation + !< + function Mf6Update() result(hasConverged) + ! -- return variable + logical(LGP) :: hasConverged + ! + ! -- prepare timestep + call Mf6PrepareTimestep() + ! + ! -- do timestep + call Mf6DoTimestep() + ! + ! -- after timestep + hasConverged = Mf6FinalizeTimestep() + ! + end function Mf6Update + + !> @brief Finalize the simulation !! !! This subroutine finalizes a simulation. Steps include: !! - final processing !! - deallocate memory !! - !< - subroutine Mf6Finalize() - ! -- modules - use, intrinsic :: iso_fortran_env, only: output_unit - use ListsModule, only: lists_da - use MemoryManagerModule, only: mem_write_usage, mem_da - use TimerModule, only: elapsed_time - use SimVariablesModule, only: iout - use SimulationCreateModule, only: simulation_da - use TdisModule, only: tdis_da - use SimModule, only: final_message - ! -- local variables - integer(I4B) :: im - integer(I4B) :: ic - integer(I4B) :: is - integer(I4B) :: isg - class(SolutionGroupType), pointer :: sgp => null() - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - ! - ! -- FINAL PROCESSING (FP) - ! -- Final processing for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_fp() - enddo - ! - ! -- Final processing for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_fp() - enddo - ! - ! -- Final processing for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_fp() - enddo - ! - ! -- DEALLOCATE (DA) - ! -- Deallocate tdis - call tdis_da() - ! - ! -- Deallocate for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_da() - deallocate(mp) - enddo - ! - ! -- Deallocate for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_da() - deallocate(ep) - enddo - ! - ! -- Deallocate for each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_da() - deallocate(mc) - enddo - ! - ! -- Deallocate for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_da() - deallocate(sp) - enddo - ! - ! -- Deallocate solution group and simulation variables - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_da() - deallocate(sgp) - enddo - call simulation_da() - call lists_da() - ! - ! -- Write memory usage, elapsed time and terminate - call mem_write_usage(iout) - call mem_da() - call elapsed_time(iout, 1) - call final_message() - ! - end subroutine Mf6Finalize - - !> @brief Print info to screen + !< + subroutine Mf6Finalize() + ! -- modules + use, intrinsic :: iso_fortran_env, only: output_unit + use ListsModule, only: lists_da + use MemoryManagerModule, only: mem_write_usage, mem_da + use TimerModule, only: elapsed_time + use SimVariablesModule, only: iout + use SimulationCreateModule, only: simulation_da + use TdisModule, only: tdis_da + use SimModule, only: final_message + ! -- local variables + integer(I4B) :: im + integer(I4B) :: ic + integer(I4B) :: is + integer(I4B) :: isg + class(SolutionGroupType), pointer :: sgp => null() + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + ! + ! -- FINAL PROCESSING (FP) + ! -- Final processing for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_fp() + end do + ! + ! -- Final processing for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_fp() + end do + ! + ! -- Final processing for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_fp() + end do + ! + ! -- DEALLOCATE (DA) + ! -- Deallocate tdis + call tdis_da() + ! + ! -- Deallocate for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_da() + deallocate (mp) + end do + ! + ! -- Deallocate for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_da() + deallocate (ep) + end do + ! + ! -- Deallocate for each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_da() + deallocate (mc) + end do + ! + ! -- Deallocate for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_da() + deallocate (sp) + end do + ! + ! -- Deallocate solution group and simulation variables + do isg = 1, solutiongrouplist%Count() + sgp => GetSolutionGroupFromList(solutiongrouplist, isg) + call sgp%sgp_da() + deallocate (sgp) + end do + call simulation_da() + call lists_da() + ! + ! -- Write memory usage, elapsed time and terminate + call mem_write_usage(iout) + call mem_da() + call elapsed_time(iout, 1) + call final_message() + ! + end subroutine Mf6Finalize + + !> @brief Print info to screen !! !! This subroutine prints the banner to the screen. !! - !< - subroutine printInfo() - use SimModule, only: initial_message - use TimerModule, only: start_time - ! - ! -- print initial message - call initial_message() - ! - ! -- get start time - call start_time() - return - end subroutine printInfo - - !> @brief Define the simulation + !< + subroutine printInfo() + use SimModule, only: initial_message + use TimerModule, only: start_time + ! + ! -- print initial message + call initial_message() + ! + ! -- get start time + call start_time() + return + end subroutine printInfo + + !> @brief Define the simulation !! !! This subroutine defined the simulation. Steps include: !! - define each model !! - define each solution !! - !< - subroutine simulation_df() - ! -- local variables - integer(I4B) :: im - integer(I4B) :: ic - integer(I4B) :: is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - - ! -- Define each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_df() - enddo - ! - ! -- Define each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_df() - enddo - ! - ! -- when needed, this is were the interface models are - ! created and added to the numerical solutions - call connections_cr() - ! - ! -- Define each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_df() - enddo - ! - ! -- Define each solution - do is = 1, basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_df() - enddo - - end subroutine simulation_df - - !> @brief Simulation allocate and read + !< + subroutine simulation_df() + ! -- local variables + integer(I4B) :: im + integer(I4B) :: ic + integer(I4B) :: is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + + ! -- Define each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_df() + end do + ! + ! -- Define each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_df() + end do + ! + ! -- when needed, this is were the interface models are + ! created and added to the numerical solutions + call connections_cr() + ! + ! -- Define each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_df() + end do + ! + ! -- Define each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_df() + end do + + end subroutine simulation_df + + !> @brief Simulation allocate and read !! - !! This subroutine allocates and read static data for the simulation. + !! This subroutine allocates and read static data for the simulation. !! Steps include: !! - allocate and read for each model !! - allocate and read for each exchange !! - allocate and read for each solution !! - !< - subroutine simulation_ar() - ! -- local variables - integer(I4B) :: im - integer(I4B) :: ic - integer(I4B) :: is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - - ! -- Allocate and read each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_ar() - enddo - ! - ! -- Allocate and read each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_ar() - enddo - ! - ! -- Allocate and read all model connections - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_ar() - enddo - ! - ! -- Allocate and read each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_ar() - enddo - ! - end subroutine simulation_ar + !< + subroutine simulation_ar() + ! -- local variables + integer(I4B) :: im + integer(I4B) :: ic + integer(I4B) :: is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + + ! -- Allocate and read each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_ar() + end do + ! + ! -- Allocate and read each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_ar() + end do + ! + ! -- Allocate and read all model connections + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_ar() + end do + ! + ! -- Allocate and read each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_ar() + end do + ! + end subroutine simulation_ar - !> @brief Create the model connections from the exchanges + !> @brief Create the model connections from the exchanges !! !! This will upgrade the numerical exchanges in the solution, - !! whenever the configuration requires this, to Connection + !! whenever the configuration requires this, to Connection !! objects. Currently we anticipate: !! !! GWF-GWF => GwfGwfConnection !! GWT-GWT => GwtGwtConecction - !< - subroutine connections_cr() - use ConnectionBuilderModule - use SimVariablesModule, only: iout - integer(I4B) :: isol - type(ConnectionBuilderType) :: connectionBuilder - class(BaseSolutionType), pointer :: sol => null() - - write(iout,'(/a)') 'PROCESSING MODEL CONNECTIONS' - - if (baseexchangelist%Count() == 0) then - ! if this is not a coupled simulation in any way, - ! then we will not need model connections - return - end if - - do isol = 1, basesolutionlist%Count() - sol => GetBaseSolutionFromList(basesolutionlist, isol) - call connectionBuilder%processSolution(sol) - end do + !< + subroutine connections_cr() + use ConnectionBuilderModule + use SimVariablesModule, only: iout + integer(I4B) :: isol + type(ConnectionBuilderType) :: connectionBuilder + class(BaseSolutionType), pointer :: sol => null() + + write (iout, '(/a)') 'PROCESSING MODEL CONNECTIONS' + + if (baseexchangelist%Count() == 0) then + ! if this is not a coupled simulation in any way, + ! then we will not need model connections + return + end if + + do isol = 1, basesolutionlist%Count() + sol => GetBaseSolutionFromList(basesolutionlist, isol) + call connectionBuilder%processSolution(sol) + end do - write(iout,'(a)') 'END OF MODEL CONNECTIONS' - end subroutine connections_cr - - !> @brief Read and prepare time step + write (iout, '(a)') 'END OF MODEL CONNECTIONS' + end subroutine connections_cr + + !> @brief Read and prepare time step !! - !! This subroutine reads and prepares period data for the simulation. + !! This subroutine reads and prepares period data for the simulation. !! Steps include: !! - read and prepare for each model !! - read and prepare for each exchange @@ -352,179 +352,179 @@ end subroutine connections_cr !! - calculate maximum time step for each solution !! - set time discretization timestep using smallest maximum timestep !! - !< - subroutine Mf6PrepareTimestep() - ! -- modules - use KindModule, only: I4B - use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE - use TdisModule, only: tdis_set_counters, tdis_set_timestep, & - kstp, kper - use ListsModule, only: basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SimModule, only: converge_reset - use SimVariablesModule, only: isim_mode - ! -- local variables - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - class(BaseSolutionType), pointer :: sp => null() - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: fmt - integer(I4B) :: im - integer(I4B) :: ie - integer(I4B) :: ic - integer(I4B) :: is - ! - ! -- initialize fmt - fmt = "(/,a,/)" - ! - ! -- period update - call tdis_set_counters() - ! - ! -- set base line - write(line, '(a,i0,a,i0,a)') & - 'start timestep kper="', kper, '" kstp="', kstp, '" mode="' - ! - ! -- evaluate simulation mode - select case (isim_mode) - case (MVALIDATE) - line = trim(line) // 'validate"' - case(MNORMAL) - line = trim(line) // 'normal"' - end select - - ! -- Read and prepare each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_message(line, fmt=fmt) - call mp%model_rp() - enddo - ! - ! -- Read and prepare each exchange - do ie = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ie) - call ep%exg_rp() - enddo - ! - ! -- Read and prepare each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_rp() - enddo - ! - ! -- reset simulation convergence flag - call converge_reset() - ! - ! -- time update for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_calculate_delt() - enddo - ! - ! -- time update for each exchange - do ie = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ie) - call ep%exg_calculate_delt() - enddo - ! - ! -- time update for each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_calculate_delt() - enddo - ! - ! -- time update for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_calculate_delt() - enddo - ! - ! -- set time step - call tdis_set_timestep() - - end subroutine Mf6PrepareTimestep - - !> @brief Run time step + !< + subroutine Mf6PrepareTimestep() + ! -- modules + use KindModule, only: I4B + use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE + use TdisModule, only: tdis_set_counters, tdis_set_timestep, & + kstp, kper + use ListsModule, only: basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SimModule, only: converge_reset + use SimVariablesModule, only: isim_mode + ! -- local variables + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + class(BaseSolutionType), pointer :: sp => null() + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: fmt + integer(I4B) :: im + integer(I4B) :: ie + integer(I4B) :: ic + integer(I4B) :: is + ! + ! -- initialize fmt + fmt = "(/,a,/)" + ! + ! -- period update + call tdis_set_counters() + ! + ! -- set base line + write (line, '(a,i0,a,i0,a)') & + 'start timestep kper="', kper, '" kstp="', kstp, '" mode="' + ! + ! -- evaluate simulation mode + select case (isim_mode) + case (MVALIDATE) + line = trim(line)//'validate"' + case (MNORMAL) + line = trim(line)//'normal"' + end select + + ! -- Read and prepare each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_message(line, fmt=fmt) + call mp%model_rp() + end do + ! + ! -- Read and prepare each exchange + do ie = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ie) + call ep%exg_rp() + end do + ! + ! -- Read and prepare each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_rp() + end do + ! + ! -- reset simulation convergence flag + call converge_reset() + ! + ! -- time update for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_calculate_delt() + end do + ! + ! -- time update for each exchange + do ie = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ie) + call ep%exg_calculate_delt() + end do + ! + ! -- time update for each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_calculate_delt() + end do + ! + ! -- time update for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_calculate_delt() + end do + ! + ! -- set time step + call tdis_set_timestep() + + end subroutine Mf6PrepareTimestep + + !> @brief Run time step !! - !! This subroutine runs a single time step for the simulation. + !! This subroutine runs a single time step for the simulation. !! Steps include: !! - formulate the system of equations for each model and exchange !! - solve each solution !! - !< - subroutine Mf6DoTimestep() - ! -- modules - use KindModule, only: I4B - use ListsModule, only: solutiongrouplist - use SimVariablesModule, only: iFailedStepRetry - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - ! -- local variables - class(SolutionGroupType), pointer :: sgp => null() - integer(I4B) :: isg - logical :: finishedTrying - - ! -- By default, the solution groups will be solved once, and - ! may fail. But if adaptive stepping is active, then - ! the solution groups may be solved over and over with - ! progressively smaller time steps to see if convergence - ! can be obtained. - iFailedStepRetry = 0 - retryloop: do - - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_ca() - enddo - - call sim_step_retry(finishedTrying) - if (finishedTrying) exit retryloop - iFailedStepRetry = iFailedStepRetry + 1 - - end do retryloop - - end subroutine Mf6DoTimestep - - !> @brief Rerun time step + !< + subroutine Mf6DoTimestep() + ! -- modules + use KindModule, only: I4B + use ListsModule, only: solutiongrouplist + use SimVariablesModule, only: iFailedStepRetry + use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList + ! -- local variables + class(SolutionGroupType), pointer :: sgp => null() + integer(I4B) :: isg + logical :: finishedTrying + + ! -- By default, the solution groups will be solved once, and + ! may fail. But if adaptive stepping is active, then + ! the solution groups may be solved over and over with + ! progressively smaller time steps to see if convergence + ! can be obtained. + iFailedStepRetry = 0 + retryloop: do + + do isg = 1, solutiongrouplist%Count() + sgp => GetSolutionGroupFromList(solutiongrouplist, isg) + call sgp%sgp_ca() + end do + + call sim_step_retry(finishedTrying) + if (finishedTrying) exit retryloop + iFailedStepRetry = iFailedStepRetry + 1 + + end do retryloop + + end subroutine Mf6DoTimestep + + !> @brief Rerun time step !! !! This subroutine reruns a single time step for the simulation when - !! the adaptive time step option is used. + !! the adaptive time step option is used. !! - !< - subroutine sim_step_retry(finishedTrying) - ! -- modules - use KindModule, only: DP - use SimVariablesModule, only: lastStepFailed - use SimModule, only: converge_reset - use TdisModule, only: kstp, kper, delt, tdis_delt_reset - use AdaptiveTimeStepModule, only: ats_reset_delt - ! -- dummy variables - logical, intent(out) :: finishedTrying !< boolean that indicates if no - ! additional reruns of the time step are required - ! - ! -- Check with ats to reset delt and keep trying - finishedTrying = .true. - call ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) - ! - if (.not. finishedTrying) then - ! - ! -- Reset delt, which requires updating pertim, totim - ! and end of period and simulation indicators - call tdis_delt_reset(delt) - ! - ! -- Reset state of the simulation convergence flag - call converge_reset() - - end if - ! - ! -- return - return - end subroutine sim_step_retry - - !> @brief Finalize time step + !< + subroutine sim_step_retry(finishedTrying) + ! -- modules + use KindModule, only: DP + use SimVariablesModule, only: lastStepFailed + use SimModule, only: converge_reset + use TdisModule, only: kstp, kper, delt, tdis_delt_reset + use AdaptiveTimeStepModule, only: ats_reset_delt + ! -- dummy variables + logical, intent(out) :: finishedTrying !< boolean that indicates if no + ! additional reruns of the time step are required + ! + ! -- Check with ats to reset delt and keep trying + finishedTrying = .true. + call ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) + ! + if (.not. finishedTrying) then + ! + ! -- Reset delt, which requires updating pertim, totim + ! and end of period and simulation indicators + call tdis_delt_reset(delt) + ! + ! -- Reset state of the simulation convergence flag + call converge_reset() + + end if + ! + ! -- return + return + end subroutine sim_step_retry + + !> @brief Finalize time step !! - !! This function finalizes a single time step for the simulation + !! This function finalizes a single time step for the simulation !! and writes output for the time step. Steps include: !! - write output for each model !! - write output for each exchange @@ -534,78 +534,78 @@ end subroutine sim_step_retry !! !! @return hasConverged boolean indicating if convergence was achieved for the time step !! - !< - function Mf6FinalizeTimestep() result(hasConverged) - ! -- modules - use KindModule, only: I4B - use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE - use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SimModule, only: converge_check - use SimVariablesModule, only: isim_mode - ! -- return variable - logical(LGP) :: hasConverged - ! -- local variables - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: fmt - integer(I4B) :: im - integer(I4B) :: ix - integer(I4B) :: ic - integer(I4B) :: is + !< + function Mf6FinalizeTimestep() result(hasConverged) + ! -- modules + use KindModule, only: I4B + use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE + use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SimModule, only: converge_check + use SimVariablesModule, only: isim_mode + ! -- return variable + logical(LGP) :: hasConverged + ! -- local variables + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: fmt + integer(I4B) :: im + integer(I4B) :: ix + integer(I4B) :: ic + integer(I4B) :: is + ! + ! -- initialize format and line + fmt = "(/,a,/)" + line = 'end timestep' + ! + ! -- evaluate simulation mode + select case (isim_mode) + case (MVALIDATE) + ! + ! -- Write final message for timestep for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_message(line, fmt=fmt) + end do + case (MNORMAL) ! - ! -- initialize format and line - fmt = "(/,a,/)" - line = 'end timestep' + ! -- Write output and final message for timestep for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_ot() + call mp%model_message(line, fmt=fmt) + end do ! - ! -- evaluate simulation mode - select case (isim_mode) - case(MVALIDATE) - ! - ! -- Write final message for timestep for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_message(line, fmt=fmt) - end do - case(MNORMAL) - ! - ! -- Write output and final message for timestep for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_ot() - call mp%model_message(line, fmt=fmt) - enddo - ! - ! -- Write output for each exchange - do ix = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ix) - call ep%exg_ot() - enddo - ! - ! -- Write output for each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_ot() - end do - ! - ! -- Write output for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_ot() - enddo - end select + ! -- Write output for each exchange + do ix = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ix) + call ep%exg_ot() + end do ! - ! -- Check if we're done - call converge_check(hasConverged) + ! -- Write output for each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_ot() + end do ! - ! -- return - return - - end function Mf6FinalizeTimestep - + ! -- Write output for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_ot() + end do + end select + ! + ! -- Check if we're done + call converge_check(hasConverged) + ! + ! -- return + return + + end function Mf6FinalizeTimestep + end module Mf6CoreModule diff --git a/src/mf6lists.f90 b/src/mf6lists.f90 index 2d3ee1f2a9a..904caddbdc7 100644 --- a/src/mf6lists.f90 +++ b/src/mf6lists.f90 @@ -23,12 +23,12 @@ module ListsModule ! -- list of all exchanges in simulation type(ListType) :: baseexchangelist - + ! -- list of all connections in simulation type(ListType) :: baseconnectionlist - - contains - + +contains + subroutine lists_da() ! ****************************************************************************** ! Deallocate the lists @@ -43,7 +43,7 @@ subroutine lists_da() call solutiongrouplist%Clear() call baseexchangelist%Clear() call baseconnectionlist%Clear() - + return end subroutine lists_da