From 70f327f48b1fc75964474c01f0a0098940d132ba Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Fri, 14 Jun 2024 13:54:23 -0600 Subject: [PATCH 01/26] build with cmake, remove mct --- CMakeLists.txt | 65 ++ src/CMakeLists.txt | 32 +- src/mct_mod.F90 | 1242 -------------------------------------- src/shr_mct_mod.F90 | 860 -------------------------- src/shr_pcdf_mod.F90 | 817 ------------------------- src/shr_reprosum_mod.F90 | 77 ++- 6 files changed, 147 insertions(+), 2946 deletions(-) create mode 100644 CMakeLists.txt delete mode 100644 src/mct_mod.F90 delete mode 100644 src/shr_mct_mod.F90 delete mode 100644 src/shr_pcdf_mod.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..af2dfbd --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,65 @@ +cmake_minimum_required(VERSION 3.10) +include(ExternalProject) +include(FetchContent) + +if (DEFINED CIMEROOT) + message("Using CIME in ${CIMEROOT} with compiler ${COMPILER}") + include(${CASEROOT}/Macros.cmake) + if (${PIO_VERSION} LESS 2) + message( FATAL_ERROR "Version 2 of the PIO library required") + endif() + if (MPILIB STREQUAL mpi-serial) + set(CMAKE_Fortran_COMPILER ${SFC}) + set(CMAKE_C_COMPILER ${SCC}) + else() + set(CMAKE_Fortran_COMPILER ${MPIFC}) + set(CMAKE_C_COMPILER ${MPICC}) + endif() + set(CMAKE_Fortran_FLAGS "${FFLAGS} ${CPPDEFS} -I${LIBROOT}/include -I${LIBROOT}/nuopc/esmf/${NINST_VALUE}/include") + add_compile_definitions(CESMCOUPLED) + list(APPEND CMAKE_MODULE_PATH ${SRC_ROOT}/cime/CIME/non_py/src/CMake) +else() + set(BLD_STANDALONE TRUE) + project(SHARE LANGUAGES Fortran C VERSION 0.1) + list(APPEND CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/cmake) +endif() +message("CMAKE_MODULE_PATH is ${CMAKE_MODULE_PATH}, CMAKE_Fortran_COMPILER is ${CMAKE_Fortran_COMPILER}") +enable_language(Fortran) + +option(WERROR "add the -Werror flag to compiler (works with gcc and intel)" OFF) + +if (DEFINED ENV{PIO_ROOT}) + message("PIO_ROOT is $ENV{PIO_ROOT}") +else() + if (DEFINED PIO) + set(PIO_PATH ${PIO}) + else() + set(PIO_PATH $ENV{PIO}) + endif() + find_package(PIO REQUIRED COMPONENT C Fortran PATH ${PIO_PATH}) +endif() + +if (NOT DEFINED MPILIB OR NOT ${MPILIB} STREQUAL "mpi-serial") + find_package(MPI REQUIRED) +endif() +set(CMAKE_MODULE_PATH "$ENV{NCAR_ROOT_ESMF}/cmake") +find_package(ESMF REQUIRED) +set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") + +if("${COMPILER}" STREQUAL "nag") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -D__NAG__") +endif() +file(GLOB GENF90SOURCES "src/*.F90.in") +set(ENABLE_GENF90 ON) +set(GENF90 "${GENF90_PATH}/genf90.pl") +include(${GENF90_PATH}/CMake/genf90_utils.cmake) +process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) +file(GLOB SOURCES "src/*.c" "src/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") +list(APPEND SOURCES "${SHAREGENF90SRC}") +add_definitions(-DCPRINTEL) + +add_library(share STATIC ${SOURCES}) +target_include_directories(share PRIVATE include RandNum/include) +#target_include_directories(share PRIVATE RandNum/include) + + diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index f68be55..9e83e33 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,9 +1,31 @@ +cmake_minimum_required(VERSION 3.26) +project(share) +include(ExternalProject) set(genf90_files shr_infnan_mod.F90.in shr_assert_mod.F90.in) +#===== genf90 ===== +if (DEFINED GENF90_PATH) + add_custom_target(genf90 + DEPENDS ${GENF90_PATH}/genf90.pl) +else () + ExternalProject_Add (genf90 + PREFIX ${CMAKE_CURRENT_BINARY_DIR}/genf90 + GIT_REPOSITORY https://github.com/PARALLELIO/genf90 + GIT_TAG origin/update_cmake_interface + UPDATE_COMMAND git pull "https://github.com/PARALLELIO/genf90" + CONFIGURE_COMMAND "" + BUILD_COMMAND "" + INSTALL_COMMAND "") + ExternalProject_Get_Property (genf90 SOURCE_DIR) + set (GENF90_PATH ${SOURCE_DIR}) + unset (SOURCE_DIR) +endif () +include(${GENF90_PATH}/CMake/genf90_utils.cmake) + process_genf90_source_list("${genf90_files}" ${CMAKE_CURRENT_BINARY_DIR} share_genf90_sources) -sourcelist_to_parent(share_genf90_sources) +#sourcelist_to_parent(share_genf90_sources) list(APPEND share_sources "${share_genf90_sources}") @@ -39,6 +61,8 @@ list(APPEND share_mct_sources list(APPEND share_pio_sources shr_pio_mod.F90) -sourcelist_to_parent(share_sources) -sourcelist_to_parent(share_mct_sources) -sourcelist_to_parent(share_pio_sources) +#sourcelist_to_parent(share_sources) +#sourcelist_to_parent(share_mct_sources) +#sourcelist_to_parent(share_pio_sources) +add_library(share ${share_sources}) +add_dependencies (share genf90) diff --git a/src/mct_mod.F90 b/src/mct_mod.F90 deleted file mode 100644 index 8a2fc59..0000000 --- a/src/mct_mod.F90 +++ /dev/null @@ -1,1242 +0,0 @@ -! !MODULE: mct_mod -- provides a standard API naming convention for MCT code -! -! !DESCRIPTION: -! This module should be used instead of accessing mct modules directly. -! This module: -! \begin{itemize} -! \item Uses Fortran {\sf use} renaming of MCT routines and data types so that they -! all have an mct\_ prefix and related data types and routines have related names. -! \item Provides easy and uniform access to -! all MCT routines and data types that must be accessed. -! \item Provides a convienient list of -! all MCT routines and data types that can be accessed. -! \item Blocks access to MCT routines that are not used in cpl6. -! \end{itemize} -! This module also includes some MCT-only functions to augment -! the MCT library. -! -! !REVISION HISTORY: -! 2001-Aug-14 - B. Kauffman - first prototype -! 2006-Apr-13 - M. Vertenstein - modified for sequential mode -! 2007-Mar-01 - R. Jacob - moved to shr -! -! !INTERFACE: ------------------------------------------------------------------ -module mct_mod - -! !USES: - - use shr_kind_mod, only: R8=>SHR_KIND_R8, IN=>SHR_KIND_IN, CL=>SHR_KIND_CL, & - CX=>SHR_KIND_CX, CXX=>SHR_KIND_CXX! shared kinds - use shr_sys_mod ! share system routines - use shr_mpi_mod ! mpi layer - use shr_const_mod ! constants - use shr_string_mod ! string functions - - use shr_log_mod ,only: s_loglev => shr_log_Level - use shr_log_mod ,only: s_logunit => shr_log_Unit - - use m_MCTWorld ,only: mct_world_init => init - use m_MCTWorld ,only: mct_world_clean => clean - - use m_AttrVect ,only: mct_aVect => AttrVect - use m_AttrVect ,only: mct_aVect_init => init - use m_AttrVect ,only: mct_aVect_clean => clean - use m_AttrVect ,only: mct_aVect_zero => zero - use m_AttrVect ,only: mct_aVect_lsize => lsize - use m_AttrVect ,only: mct_aVect_indexIA => indexIA - use m_AttrVect ,only: mct_aVect_indexRA => indexRA - use m_AttrVect ,only: mct_aVect_importIattr => importIattr - use m_AttrVect ,only: mct_aVect_exportIattr => exportIattr - use m_AttrVect ,only: mct_aVect_importRattr => importRattr - use m_AttrVect ,only: mct_aVect_exportRattr => exportRattr - use m_AttrVect ,only: mct_aVect_getIList => getIList - use m_AttrVect ,only: mct_aVect_getRList => getRList - use m_AttrVect ,only: mct_aVect_getIList2c => getIListToChar - use m_AttrVect ,only: mct_aVect_getRList2c => getRListToChar - use m_AttrVect ,only: mct_aVect_exportIList2c=> exportIListToChar - use m_AttrVect ,only: mct_aVect_exportRList2c=> exportRListToChar - use m_AttrVect ,only: mct_aVect_nIAttr => nIAttr - use m_AttrVect ,only: mct_aVect_nRAttr => nRAttr - use m_AttrVect ,only: mct_aVect_copy => Copy - use m_AttrVect ,only: mct_aVect_permute => Permute - use m_AttrVect ,only: mct_aVect_unpermute => Unpermute - use m_AttrVect ,only: mct_aVect_SharedIndices=> AVSharedIndices - use m_AttrVect ,only: mct_aVect_setSharedIndices=> SharedIndices - use m_AttrVectComms ,only: mct_aVect_scatter => scatter - use m_AttrVectComms ,only: mct_aVect_gather => gather - use m_AttrVectComms ,only: mct_aVect_bcast => bcast - - use m_GeneralGrid ,only: mct_gGrid => GeneralGrid - use m_GeneralGrid ,only: mct_gGrid_init => init - use m_GeneralGrid ,only: mct_gGrid_clean => clean - use m_GeneralGrid ,only: mct_gGrid_dims => dims - use m_GeneralGrid ,only: mct_gGrid_lsize => lsize - use m_GeneralGrid ,only: mct_ggrid_indexIA => indexIA - use m_GeneralGrid ,only: mct_gGrid_indexRA => indexRA - use m_GeneralGrid ,only: mct_gGrid_exportRattr => exportRattr - use m_GeneralGrid ,only: mct_gGrid_importRattr => importRattr - use m_GeneralGrid ,only: mct_gGrid_exportIattr => exportIattr - use m_GeneralGrid ,only: mct_gGrid_importIattr => importIattr - use m_GeneralGrid ,only: mct_gGrid_permute => permute - use m_GeneralGridComms ,only: mct_gGrid_scatter => scatter - use m_GeneralGridComms ,only: mct_gGrid_gather => gather - use m_GeneralGridComms ,only: mct_gGrid_bcast => bcast - - use m_Transfer ,only: mct_send => Send - use m_Transfer ,only: mct_recv => Recv - - use m_GlobalSegMap ,only: mct_gsMap => GlobalSegMap - use m_GlobalSegMap ,only: mct_gsMap_init => init - use m_GlobalSegMap ,only: mct_gsMap_clean => clean - use m_GlobalSegMap ,only: mct_gsMap_lsize => lsize - use m_GlobalSegMap ,only: mct_gsMap_gsize => gsize - use m_GlobalSegMap ,only: mct_gsMap_gstorage => GlobalStorage - use m_GlobalSegMap ,only: mct_gsMap_ngseg => ngseg - use m_GlobalSegMap ,only: mct_gsMap_nlseg => nlseg - use m_GlobalSegMap ,only: mct_gsMap_maxnlseg => max_nlseg - use m_GlobalSegMap ,only: mct_gsMap_activepes => active_pes - use m_GlobalSegMap ,only: mct_gsMap_copy => copy - use m_GlobalSegMap ,only: mct_gsMap_increasing => increasing - use m_GlobalSegMap ,only: mct_gsMap_orderedPoints=> OrderedPoints - use m_GlobalSegMapComms ,only: mct_gsMap_bcast => bcast - - use m_Rearranger ,only: mct_rearr => Rearranger - use m_Rearranger ,only: mct_rearr_init => init - use m_Rearranger ,only: mct_rearr_clean => clean - use m_Rearranger ,only: mct_rearr_print => print - use m_Rearranger ,only: mct_rearr_rearrange => rearrange - - use m_Router ,only: mct_router => Router - use m_Router ,only: mct_router_init => init - - use m_SparseMatrixToMaps ,only: mct_sMat_2XgsMap => SparseMatrixToXGlobalSegMap - use m_SparseMatrixToMaps ,only: mct_sMat_2YgsMap => SparseMatrixToYGlobalSegMap - use m_SparseMatrix ,only: mct_sMat => SparseMatrix - use m_SparseMatrix ,only: mct_sMat_Init => init - use m_SparseMatrix ,only: mct_sMat_Vecinit => vecinit - use m_SparseMatrix ,only: mct_sMat_Clean => clean - use m_SparseMatrix ,only: mct_sMat_indexIA => indexIA - use m_SparseMatrix ,only: mct_sMat_indexRA => indexRA - use m_SparseMatrix ,only: mct_sMat_lsize => lsize - use m_SparseMatrix ,only: mct_sMat_nrows => nRows - use m_SparseMatrix ,only: mct_sMat_ncols => nCols - use m_SparseMatrix ,only: mct_sMat_SortPermute => SortPermute - use m_SparseMatrix ,only: mct_sMat_GNumEl => GlobalNumElements - use m_SparseMatrix ,only: mct_sMat_ImpGRowI => ImportGlobalRowIndices - use m_SparseMatrix ,only: mct_sMat_ImpGColI => ImportGlobalColumnIndices - use m_SparseMatrix ,only: mct_sMat_ImpLRowI => ImportLocalRowIndices - use m_SparseMatrix ,only: mct_sMat_ImpLColI => ImportLocalColumnIndices - use m_SparseMatrix ,only: mct_sMat_ImpMatrix => ImportMatrixElements - use m_SparseMatrix ,only: mct_sMat_ExpGRowI => ExportGlobalRowIndices - use m_SparseMatrix ,only: mct_sMat_ExpGColI => ExportGlobalColumnIndices - use m_SparseMatrix ,only: mct_sMat_ExpLRowI => ExportLocalRowIndices - use m_SparseMatrix ,only: mct_sMat_ExpLColI => ExportLocalColumnIndices - use m_SparseMatrix ,only: mct_sMat_ExpMatrix => ExportMatrixElements - use m_SparseMatrixComms ,only: mct_sMat_ScatterByRow => ScatterByRow - use m_SparseMatrixComms ,only: mct_sMat_ScatterByCol => ScatterByColumn - use m_SparseMatrixPlus ,only: mct_sMatP => SparseMatrixPlus - use m_SparseMatrixPlus ,only: mct_sMatP_Init => init - use m_SparseMatrixPlus ,only: mct_sMatP_Vecinit => vecinit - use m_SparseMatrixPlus ,only: mct_sMatP_clean => clean - use m_MatAttrVectMul ,only: mct_sMat_avMult => sMatAvMult - use m_GlobalToLocal ,only: mct_sMat_g2lMat => GlobalToLocalMatrix - - use m_List ,only: mct_list => list - use m_List ,only: mct_list_init => init - use m_List ,only: mct_list_get => get - use m_List ,only: mct_list_nitem => nitem - use m_List ,only: mct_list_clean => clean - use m_string ,only: mct_string => string - use m_string ,only: mct_string_clean => clean - use m_string ,only: mct_string_toChar => toChar - use m_die ,only: mct_perr_die => mp_perr_die - use m_die ,only: mct_die => die - use m_inpak90 - - use m_Permuter ,only: mct_permute => Permute - - use m_MergeSorts ,only: mct_indexset => IndexSet - use m_MergeSorts ,only: mct_indexsort => IndexSort - - implicit none - - public :: mct_aVect_info - public :: mct_aVect_fldIndex - public :: mct_aVect_sharedFields - public :: mct_aVect_initSharedFields - public :: mct_aVect_getRAttr - public :: mct_aVect_putRAttr - public :: mct_aVect_accum - public :: mct_aVect_avg - public :: mct_avect_mult - public :: mct_avect_vecmult - public :: mct_rearr_rearrange_fldlist - public :: mct_gsmap_identical - - logical,public :: mct_usealltoall = .false. - logical,public :: mct_usevector = .false. - -!EOP - - !--- local use of kinds --- - - private :: R8, IN, CL, CX, CXX - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_info - print out aVect info for debugging -! -! !DESCRIPTION: -! Print out information about the input MCT {\it AttributeVector} -! {\tt aVect} to stdout. {\tt flag} sets the level of information: -! \begin{enumerate} -! \item print out names of attributes in {\tt aVect}. -! \item also print out local max and min of data in {\tt aVect}. -! \item also print out global max and min of data in {\tt aVect}. -! \item Same as 3 but include name of this routine. -! \end{enumerate} -! If {\tt flag} is 3 or higher, then optional argument {\tt comm} -! must be provided. -! If optional argument {\tt fld} is present, only information for -! that field will be printed. -! If optional argument {\tt istr} is present, it will be output -! before any of the information. -! -! -! !REVISION HISTORY: -! 2003 Jul 01 - B. Kauffman, T. Craig - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_aVect_info(flag,aVect,comm,pe,fld,istr) - -! !USES: - -! !INPUT/OUTPUT PARAMETERS: - - integer(IN) ,intent(in) :: flag ! info level flag - type(mct_aVect),intent(in) :: aVect ! Attribute vector - integer(IN) ,intent(in),optional :: comm ! MPI communicator - integer(IN) ,intent(in),optional :: pe ! processor number - character(*) ,intent(in),optional :: fld ! fld - character(*) ,intent(in),optional :: istr ! string for print - -!EOP - - !--- local --- - integer(IN) :: i,j,k,n ! generic indicies - integer(IN) :: ks,ke ! start and stop k indices - integer(IN) :: nflds ! number of flds in AV to diagnose - integer(IN) :: nsize ! grid point size of AV - type(mct_string) :: item ! mct string - character(CL) :: itemc ! item converted to char - integer(IN) :: comm_loc ! local variable for comm - integer(IN) :: pe_loc ! local variable for pe - logical :: commOK ! is comm available - logical :: peOK ! is pe available - real(R8),allocatable :: minl(:) ! local min - real(R8),allocatable :: ming(:) ! global min - real(R8),allocatable :: maxl(:) ! local max - real(R8),allocatable :: maxg(:) ! global max - - !--- formats --- - character(*),parameter :: subName = '(mct_aVect_info) ' - character(*),parameter :: F00 = "('(mct_aVect_info) ',8a)" - character(*),parameter :: F01 = "('(mct_aVect_info) ',a,i9)" - character(*),parameter :: F02 = "('(mct_aVect_info) ',240a)" - character(*),parameter :: F03 = "('(mct_aVect_info) ',a,2es11.3,i4,2x,a)" - character(*),parameter :: F04 = "('(mct_aVect_info) ',a,2es11.3,2x,a)" - -!------------------------------------------------------------------------------- -! NOTE: has hard-coded knowledge/assumptions about mct aVect data type internals -!------------------------------------------------------------------------------- - - commOK = .false. - peOK = .false. - - if (present(pe)) then - peOK = .true. - pe_loc = pe - endif - - if (present(comm)) then - commOK = .true. - comm_loc = comm - if (.not.PEOK) then - call shr_mpi_commrank(comm,pe_loc,subName) - peOK = .true. - endif - endif - - if (present(fld)) then - nflds = 1 - ks = mct_aVect_indexRA(aVect,fld,perrWith=subName) - ke = ks - else - nflds = mct_aVect_nRAttr(aVect) - ks = 1 - ke = nflds - endif - - if ((peOK .and. pe_loc == 0) .or. .not.peOK) then - if (flag >= 1) then - if (present(istr)) then - if (s_loglev > 0) write(s_logunit,*) trim(istr) - endif - if (s_loglev > 0) write(s_logunit,F01) "local size =",mct_aVect_lsize(aVect) - if (associated(aVect%iList%bf)) then - if (s_loglev > 0) write(s_logunit,F02) "iList = ",aVect%iList%bf - endif - if (associated(aVect%rList%bf)) then - if (s_loglev > 0) write(s_logunit,F02) "rList = ",aVect%rList%bf - endif - endif - - if (flag >= 2) then - allocate(minl(nflds), maxl(nflds)) - do k=ks,ke - minl(k) = minval(aVect%rAttr(k,:)) - maxl(k) = maxval(aVect%rAttr(k,:)) - enddo - - if (flag >= 4 .and. commOK) then - allocate(ming(nflds), maxg(nflds)) - ming = 0._R8 - maxg = 0._R8 - call shr_mpi_min(minl,ming,comm,subName) - call shr_mpi_max(maxl,maxg,comm,subName) - endif - - do k=ks,ke - call mct_aVect_getRList(item,k,aVect) - itemc = mct_string_toChar(item) - call mct_string_clean(item) - if (s_loglev > 0) write(s_logunit,F04) 'l min/max ',minl(k),maxl(k), trim(itemc) - if (flag >= 3 .and. commOK) then - if (s_loglev > 0) write(s_logunit,F03) 'g min/max ',ming(k),maxg(k),k,trim(itemc) - endif - if (flag >= 4 .and. commOK) then - if (s_loglev > 0) write(s_logunit,*) trim(subName),'g min/max ',ming(k),maxg(k),k,trim(itemc) - endif - enddo - - deallocate(minl, maxl) - if (flag >= 4 .and. commOK) then - deallocate(ming, maxg) - endif - end if - endif - - call shr_sys_flush(s_logunit) - -end subroutine mct_aVect_info - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_fldIndex - get a real fld index from an AVect -! -! !DESCRIPTION: -! Get the field index for a real field in an attribute vector. -! This is like mct_aVect_indexRA but with a calling interface -! that returns the index without any error messages. -! -! !REMARKS: -! This is like the MCT routine indexRA -! -! !REVISION HISTORY: -! 2010 Oct 27 - T. Craig - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -integer function mct_aVect_fldIndex(aVect,fld) - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect),intent(in) :: aVect ! an Attribute vector - character(*) ,intent(in) :: fld ! field name string - -!EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "(mct_aVect_fldIndex) " - character(*),parameter :: F00 = "('(mct_aVect_fldIndex) ',8a)" - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - mct_aVect_fldIndex = mct_aVect_indexRA(aVect,trim(fld),perrWith='quiet') - -end function mct_aVect_fldIndex - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_sharedFields - get a shared real fld index from two AVects -! -! !DESCRIPTION: -! Get the shared field index for a real field in two attribute vectors. -! -! !REMARKS: -! -! !REVISION HISTORY: -! 2013 Jul 17 - T. Craig - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_aVect_sharedFields(aVect1, aVect2, rlistout, ilistout) - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect),intent(in) :: aVect1 ! an Attribute vector - type(mct_aVect),intent(in) :: aVect2 ! an Attribute vector - character(*) ,intent(inout),optional :: rlistout ! field name string - character(*) ,intent(inout),optional :: ilistout ! field name string - -!EOP - - !--- local --- - integer(IN) :: nflds1,nflds2 - character(len=CXX) :: list1,list2 - - !--- formats --- - character(*),parameter :: subName = "(mct_aVect_sharedFields) " - character(*),parameter :: F00 = "('(mct_aVect_sharedFields) ',8a)" - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - if (present(rlistout)) then - nflds1 = mct_aVect_nRAttr(aVect1) - nflds2 = mct_aVect_nRAttr(aVect2) - rlistout = '' - list1 = '' - list2 = '' - if (nflds1 > 0 .and. nflds2 > 0) then - list1 = mct_aVect_exportRList2c(aVect1) - list2 = mct_aVect_exportRlist2c(aVect2) - call shr_string_listIntersect(list1,list2,rlistout) - endif - endif - - if (present(ilistout)) then - nflds1 = mct_aVect_nIAttr(aVect1) - nflds2 = mct_aVect_nIAttr(aVect2) - ilistout = '' - list1 = '' - list2 = '' - if (nflds1 > 0 .and. nflds2 > 0) then - list1 = mct_aVect_exportIList2c(aVect1) - list2 = mct_aVect_exportIlist2c(aVect2) - call shr_string_listIntersect(list1,list2,ilistout) - endif - endif - -end subroutine mct_aVect_sharedFields - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_initSharedFields - init new AVect based on shared fields -! from two input aVects -! -! !DESCRIPTION: -! Init new AVect based on shared fields of two input AVects -! -! !REMARKS: -! -! !REVISION HISTORY: -! 2013 Jul 17 - T. Craig - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_aVect_initSharedFields(aVect1, aVect2, aVect3, lsize) - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect),intent(in) :: aVect1 ! an Attribute vector - type(mct_aVect),intent(in) :: aVect2 ! an Attribute vector - type(mct_aVect),intent(inout) :: aVect3 ! new Attribute vector - integer(IN) ,intent(in) :: lsize ! aVect3 size - -!EOP - - !--- local --- - character(len=CXX) :: rlist,ilist - - !--- formats --- - character(*),parameter :: subName = "(mct_aVect_initSharedFields) " - character(*),parameter :: F00 = "('(mct_aVect_initSharedFields) ',8a)" - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - call mct_aVect_sharedFields(aVect1,aVect2,rlist,ilist) - call mct_aVect_init(aVect3,ilist,rlist,lsize) - -end subroutine mct_aVect_initSharedFields - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_getRAttr - get real F90 array data out of an aVect -! -! !DESCRIPTION: -! Get the data associated with attribute {\tt str} in -! {\it AttributeVector} {\tt aVect} and return in the -! real F90 array data {\tt data}. -! {\tt rcode} will be 0 if succesful, 1 if size of {\tt data} -! does not match size of {\tt aVect} and 2 if {\tt str} is -! not found. -! -! !REMARKS: -! This is like the MCT routine exportRAttr except the output argument -! is not a pointer. -! -! !REVISION HISTORY: -! 2002 Apr xx - B. Kauffman - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_aVect_getRAttr(aVect,str,data,rcode) - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect) ,intent(in) :: aVect ! an Attribute vector - character(*) ,intent(in) :: str ! field name string - real(R8) ,intent(out) :: data(:) ! an F90 array - integer(IN) ,intent(out) :: rcode ! return code - -!EOP - - !--- local --- - integer(IN) :: k,n,m - - !--- formats --- - character(*),parameter :: subName = "(mct_aVect_getRAttr) " - character(*),parameter :: F00 = "('(mct_aVect_getRAttr) ',8a)" - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - rcode = 0 - - n = mct_aVect_lsize(aVect) - m = size(data) - if (n /= m) then - if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: size aV,data,attr = ",n,m,trim(str) - data = SHR_CONST_SPVAL - rcode = 1 - return - end if - - k = mct_aVect_indexRA(aVect,trim(str) ,perrWith=subName) - if ( k < 1) then - if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: attribute not found, var = ",trim(str),", k=",k - data = SHR_CONST_SPVAL - rcode = 2 - return - end if - - data(:) = aVect%rAttr(k,:) - -end subroutine mct_aVect_getRAttr - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_putRAttr - put real F90 array data into an aVect -! -! !DESCRIPTION: -! Put the data in array {\tt data} into the {\it AttributeVector} -! {\tt aVect} under the attribute {\tt str}. -! {\tt rcode} will be 0 if succesful, 1 if size of {\tt data} -! does not match size of {\tt aVect} and 2 if {\tt str} is not -! found. -! -! !REMARKS: -! This is like the MCT routine importRAttr except the output argument -! is not a pointer. - -! !REVISION HISTORY: -! 2002 Apr xx - B. Kauffman - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_aVect_putRAttr(aVect,str,data,rcode) - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect),intent(inout) :: aVect ! Attribute vector - character(*) ,intent(in) :: str - real(R8) ,intent(in) :: data(:) - integer(IN) ,intent(out) :: rcode - -!EOP - - !--- local --- - integer(IN) :: k,n,m - - !--- formats --- - character(*),parameter :: subName = "(mct_aVect_putRAttr) " - character(*),parameter :: F00 = "('(mct_aVect_putRAttr) ',8a)" - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - rcode = 0 - - n = mct_aVect_lsize(aVect) - m = size(data) - if (n /= m) then - if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: size aV,data,attr = ",n,m,trim(str) - rcode = 1 - return - end if - - k = mct_aVect_indexRA(aVect,trim(str) ,perrWith=subName) - if ( k < 1) then - if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: attribute not found, var = ",trim(str),", k=",k - rcode = 2 - return - end if - - aVect%rAttr(k,:) = data(:) - -end subroutine mct_aVect_putRAttr - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_accum - accumulate attributes from one aVect to another -! -! !DESCRIPTION: -! This routine accumulates from input argment {\tt aVin} into the output -! {\it AttrVect} argument {\tt aVout} the real and integer attributes specified in -! input {\tt CHARACTER} argument {\tt iList} and {\tt rList}. The attributes can -! be listed in any order. If neither {\tt iList} nor {\tt rList} are provided, -! all attributes shared between {\tt aVin} and {\tt aVout} will be copied. -! -! If any attributes in {\tt aVout} have different names but represent the -! the same quantity and should still be copied, you must provide a translation -! argument {\tt TrList} and/or {\tt TiList}. The translation arguments should -! be identical to the {\tt rList} or {\tt iList} but with the correct {\tt aVout} -! name subsititued at the appropriate place. -! -! This routine leverages the mct copy routines directly -! -! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized or -! if any of the specified attributes are not present in either {\tt aVout} or {\tt aVin}. -! -! !REVISION HISTORY: -! 2002 Sep 15 - ? - initial version. -! 2013-Jul-20 - T. Craig -- updated -! -! !INTERFACE: ------------------------------------------------------------------ - - subroutine mct_avect_accum(aVin, aVout, rList, TrList, iList, TiList, vector, sharedIndices,counter) - - implicit none - -! !INPUT PARAMETERS: - - type(mct_avect), intent(in) :: aVin - character(len=*), optional, intent(in) :: iList - character(len=*), optional, intent(in) :: rList - character(len=*), optional, intent(in) :: TiList - character(len=*), optional, intent(in) :: TrList - logical, optional, intent(in) :: vector - type(mct_avect_SharedIndices), optional, intent(in) :: sharedIndices - -! !OUTPUT PARAMETERS: - - type(mct_avect), intent(inout) :: aVout - integer, optional, intent(inout) :: counter - - -! !REVISION HISTORY: - -!EOP ___________________________________________________________________ - - !--- local --- - logical :: usevector - integer(IN) :: lsize,nflds,npts,i,j - type(mct_avect) :: avotmp ! temporary aVout copy - character(*),parameter :: subName = '(mct_aVect_accum) ' - -!----------------------------------------------------------------- - - usevector = .false. - if (present(vector)) then - usevector = vector - endif - - if (present(counter)) then - counter = counter + 1 - endif - - ! --- allocate avotmp, a duplciate of aVout - - lsize = mct_aVect_lsize(aVout) - call mct_avect_init(avotmp,aVout,lsize) - call mct_avect_zero(avotmp) - - ! --- copy aVin fields into avotmp - - if (present(sharedIndices)) then - - if (present(rList) .and. present(iList)) then - if (present(trList) .and. present(tilist)) then - call mct_avect_copy(aVin, avotmp, rList, TrList, iList, tiList, vector = usevector, sharedIndices=sharedIndices) - elseif (present(trList)) then - call mct_avect_copy(aVin, avotmp, rList, TrList, iList, vector = usevector, sharedIndices=sharedIndices) - elseif (present(tiList)) then - call mct_avect_copy(aVin, avotmp, rList, iList=iList, tiList=tiList, vector = usevector, sharedIndices=sharedIndices) - else - call mct_avect_copy(aVin, avotmp, rList=rList, iList=iList, vector = usevector, sharedIndices=sharedIndices) - endif - else if (present(rList)) then - if (present(trList)) then - call mct_avect_copy(aVin, avotmp, rList, TrList, vector = usevector, sharedIndices=sharedIndices) - else - call mct_avect_copy(aVin, avotmp, rList, vector = usevector, sharedIndices=sharedIndices) - endif - - else if (present(iList)) then - if (present(tiList)) then - call mct_avect_copy(aVin, avotmp, ilist=iList, tiList=tiList, vector = usevector, sharedIndices=sharedIndices) - else - call mct_avect_copy(aVin, avotmp, ilist=iList, vector = usevector, sharedIndices=sharedIndices) - endif - - else - call mct_avect_copy(aVin, avotmp, vector=usevector, sharedIndices=sharedIndices) - - endif - - else ! sharedIndices - - if (present(rList) .and. present(iList)) then - if (present(trList) .and. present(tilist)) then - call mct_avect_copy(aVin, avotmp, rList, TrList, iList, tiList, vector = usevector) - elseif (present(trList)) then - call mct_avect_copy(aVin, avotmp, rList, TrList, iList, vector = usevector) - elseif (present(tiList)) then - call mct_avect_copy(aVin, avotmp, rList, iList=iList, tiList=tiList, vector = usevector) - else - call mct_avect_copy(aVin, avotmp, rList=rList, iList=iList, vector = usevector) - endif - else if (present(rList)) then - if (present(trList)) then - call mct_avect_copy(aVin, avotmp, rList, TrList, vector = usevector) - else - call mct_avect_copy(aVin, avotmp, rList, vector = usevector) - endif - - else if (present(iList)) then - if (present(tiList)) then - call mct_avect_copy(aVin, avotmp, ilist=iList, tiList=tiList, vector = usevector) - else - call mct_avect_copy(aVin, avotmp, ilist=iList, vector = usevector) - endif - - else - call mct_avect_copy(aVin, avotmp, vector=usevector) - - endif - - endif ! shared indices - - ! --- accumulate avotmp into avout - - nflds = mct_aVect_nRAttr(aVout) - npts = mct_aVect_lsize (aVout) -!DIR$ CONCURRENT -!DIR$ PREFERVECTOR - do i=1,npts - do j=1,nflds - aVout%rattr(j,i) = aVout%rattr(j,i) + avotmp%rattr(j,i) - enddo - enddo - - ! --- clean avotmp - - call mct_avect_clean(avotmp) - - end subroutine mct_avect_accum - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_aVect_avg - averages an accumulated attribute vector -! -! !DESCRIPTION: -! Average the data in attribute vector {\tt aVect}. Divides all fields in -! the attribute vector {\tt aVect} by the value of the input counter. -! -! !REVISION HISTORY: -! 2002-Sep-15 - T. Craig -- initial version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_aVect_avg(aVect, counter) - -! !USES: - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect),intent(inout) :: aVect ! bundle to read - integer ,intent(in) :: counter ! counter - -!EOP - - !--- local --- - integer(IN) :: i,j ! generic indicies - integer(IN) :: npts ! number of points (local) in an aVect field - integer(IN) :: nflds ! number of aVect fields (real) - real(R8) :: ravg ! accumulation count - - !--- formats --- - character(*),parameter :: subName = '(mct_aVect_avg) ' - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - if (counter == 0 .or. counter == 1) return - - ravg = 1.0_R8/real(counter,R8) - - nflds = mct_aVect_nRAttr(aVect) - npts = mct_aVect_lsize (aVect) -!DIR$ CONCURRENT -!DIR$ PREFERVECTOR - do i=1,npts - do j=1,nflds - aVect%rattr(j,i) = aVect%rattr(j,i)*ravg - enddo - enddo - -end subroutine mct_aVect_avg - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_avect_mult - multiply an attribute vector by a field. -! -! !DESCRIPTION: -! Replace each field in {\tt av} by the product of that field and the -! field {\tt fld1} from input argument {\tt av1}. -! -! If optional argument {\tt bunlist} is present, only those attributes -! in {\tt bun} will be replaced. -! -! If optional argument {\tt initav} is present, then the data in {\tt av} -! is replaced by the product of the data in {\tt initav} and {\tt fld1} -! from {\tt av1}. NOTE: this assume {\tt initav} has the exact same -! attributes in the same order as {\tt av}. -! -! -! !REVISION HISTORY: -! 2007-Jun-11 - M. Vertenstein -- initial version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_avect_mult(av,av1,fld1,avlist) - -! !USES: - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect) ,intent(inout) :: av ! attribute vector output - type(mct_aVect) ,intent(in) :: av1 ! attribute vector input - character(*) ,intent(in) :: fld1 ! av1 field name - character(*),optional,intent(in) :: avlist ! sublist of field in av - -!EOP - - !--- local --- - integer(IN) :: n,m ! generic indicies - integer(IN) :: npts ! number of points (local) in an aVect field - integer(IN) :: nfld ! number of fields (local) in an aVect field - integer(IN) :: nptsx ! number of points (local) in an aVect field - integer(IN) :: kfld ! field number of fld1 in av1 - integer(IN),dimension(:),allocatable :: kfldin ! field numbers of avlist in av - type(mct_list) :: blist ! avlist as a List - type(mct_string) :: tattr ! an attribute - - !--- formats --- - character(*),parameter :: subName = '(mct_aVect_mult) ' - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - nptsx = mct_aVect_lsize(av1) - npts = mct_aVect_lsize(av) - if (nptsx /= npts .and. s_loglev > 0) write(s_logunit,*) subName,' ERROR: npts error1 ',npts,nptsx - - kfld = mct_aVect_indexRA(av1,fld1,perrWith=subName) - - if (present(avlist)) then - - call mct_list_init(blist,avlist) - - nfld=mct_list_nitem(blist) - - allocate(kfldin(nfld)) - do m=1,nfld - call mct_list_get(tattr,m,blist) - kfldin(m) = mct_aVect_indexRA(av,mct_string_toChar(tattr)) - call mct_string_clean(tattr) - enddo - call mct_list_clean(blist) - -#ifdef CPP_VECTOR - do m=1,nfld -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT - do n=1,npts -#else - do n=1,npts - do m=1,nfld -#endif - av%rAttr(kfldin(m),n) = av%rAttr(kfldin(m),n)*av1%rAttr(kfld,n) - enddo - enddo - - deallocate(kfldin) - - else - - nfld = mct_aVect_nRAttr(av) - -#ifdef CPP_VECTOR - do m=1,nfld -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT - do n=1,npts -#else - do n=1,npts - do m=1,nfld -#endif - av%rAttr(m,n) = av%rAttr(m,n)*av1%rAttr(kfld,n) - enddo - enddo - - endif - -end subroutine mct_aVect_mult - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: mct_avect_vecmult - multiply an attribute vector by a field. -! -! !DESCRIPTION: -! Replace each field in {\tt av} by the product of that field and the -! field {\tt fld1} from input argument {\tt av1}. -! -! If optional argument {\tt bunlist} is present, only those attributes -! in {\tt bun} will be replaced. -! -! If optional argument {\tt initav} is present, then the data in {\tt av} -! is replaced by the product of the data in {\tt initav} and {\tt fld1} -! from {\tt av1}. NOTE: this assume {\tt initav} has the exact same -! attributes in the same order as {\tt av}. -! -! -! !REVISION HISTORY: -! 2007-Jun-11 - M. Vertenstein -- initial version -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine mct_avect_vecmult(av,vec,avlist,mask_spval) - -! !USES: - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect) ,intent(inout) :: av ! attribute vector output - real(R8) ,intent(in) :: vec(:) - character(*),optional,intent(in) :: avlist ! sublist of field in av - logical, optional ,intent(in) :: mask_spval - -!EOP - - !--- local --- - integer(IN) :: n,m,p ! generic indicies - integer(IN) :: npts ! number of points (local) in an aVect field - integer(IN) :: nfld ! number of fields (local) in an aVect field - integer(IN) :: nptsx ! number of points (local) in an aVect field - logical :: lmspval ! local mask spval - integer(IN),dimension(:),allocatable :: kfldin ! field numbers of avlist in av - type(mct_list) :: blist ! avlist as a List - type(mct_string) :: tattr ! an attribute - - !--- formats --- - character(*),parameter :: subName = '(mct_aVect_vecmult) ' - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - lmspval = .false. - if (present(mask_spval)) then - lmspval = mask_spval - endif - - nptsx = size(vec,1) - npts = mct_aVect_lsize(av) - if (nptsx /= npts .and. s_loglev > 0) write(s_logunit,*) subName,' ERROR: npts error1 ',npts,nptsx - - - if (present(avlist)) then - - call mct_list_init(blist,avlist) - - nfld=mct_list_nitem(blist) - - allocate(kfldin(nfld)) - do m=1,nfld - call mct_list_get(tattr,m,blist) - kfldin(m) = mct_aVect_indexRA(av,mct_string_toChar(tattr)) - call mct_string_clean(tattr) - enddo - call mct_list_clean(blist) - - if (lmspval) then - - !$omp simd - do n = 1, npts - do p = 1, nfld - if (.not. shr_const_isspval(av%rAttr(kfldin(p),n))) then - av%rAttr(kfldin(p),n) = av%rAttr(kfldin(p),n)*vec(n) - end if - end do - end do - - else ! lmspval - - !$omp simd - do n = 1, npts - do p = 1, nfld - av%rAttr(kfldin(p),n) = av%rAttr(kfldin(p),n)*vec(n) - end do - end do - - endif ! lmspval - - deallocate(kfldin) - - else ! avlist - - nfld = mct_aVect_nRAttr(av) - - if (lmspval) then - - !$omp simd - do n=1,npts - where (.not. shr_const_isspval(av%rAttr(:,n))) - av%rAttr(:,n) = av%rAttr(:,n)*vec(n) - endwhere - enddo - - else ! lmspval - - !$omp simd - do n=1,npts - av%rAttr(:,n) = av%rAttr(:,n)*vec(n) - enddo - - endif ! lmspval - - endif ! avlist - -end subroutine mct_aVect_vecmult - -!=============================================================================== -! !BOP =========================================================================== -! -! !IROUTINE: subroutine mct_rearr_rearrange_fldlst - rearrange on a fieldlist -! -! !DESCRIPTION: -! Perform regarranger between two attribute vectors only on the fieldlist -! that is provided -! -! -! !REVISION HISTORY: -! 2007-Jun-22 - M. Vertenstein - first version -! -! !INTERFACE: ----------------------------------------------------------------- - -subroutine mct_rearr_rearrange_fldlist(avi, avo, Rearr, vector, alltoall, fldlist, tag) - -! !USES: - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_aVect) , intent(in) :: avi - type(mct_aVect) , intent(inout):: avo - type(mct_rearr) , intent(in) :: Rearr - logical , intent(in) :: vector - logical , intent(in) :: alltoall - character(len=*), intent(in) :: fldlist - integer(IN) , intent(in),optional :: tag -! !EOP - - !---local --- - type(mct_aVect) :: avi_fl - type(mct_aVect) :: avo_fl - integer(IN) :: lsize - integer(IN) :: ltag - - !--- formats --- - character(*),parameter :: subName = '(mct_rearr_rearrange_fldlist) ' - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - if (present(tag)) then - ltag = tag - else - ltag = 3000 - endif - - lsize = mct_aVect_lsize(avi) - call mct_aVect_init (avi_fl, rlist=fldlist, lsize=lsize) - call mct_aVect_zero (avi_fl) - - lsize = mct_aVect_lsize(avo) - call mct_aVect_init (avo_fl, rlist=fldlist, lsize=lsize) - call mct_aVect_zero (avo_fl) - - call mct_aVect_copy (aVin=avi, aVout=avi_fl) - call mct_rearr_rearrange(avi_fl, avo_fl, Rearr, VECTOR=vector, ALLTOALL=alltoall, tag=ltag) - call mct_aVect_copy (aVin=avo_fl, aVout=avo, vector=vector) - - call mct_aVect_clean(avi_fl) - call mct_aVect_clean(avo_fl) - -end subroutine mct_rearr_rearrange_fldlist - -!======================================================================= -logical function mct_gsmap_Identical(gsmap1,gsmap2) - - implicit none - type(mct_gsMap), intent(IN):: gsmap1 - type(mct_gsMap), intent(IN):: gsmap2 - - ! Local variables - - character(len=*),parameter :: subname = "(mct_gsmap_Identical) " - integer :: n - logical :: identical - - !----------------------- - - identical = .true. - - ! --- continue compare --- - if (identical) then - if (mct_gsMap_gsize(gsmap1) /= mct_gsMap_gsize(gsmap2)) identical = .false. - if (mct_gsMap_ngseg(gsmap1) /= mct_gsMap_ngseg(gsmap2)) identical = .false. - endif - - ! --- continue compare --- - if (identical) then - do n = 1,mct_gsMap_ngseg(gsmap1) - if (gsmap1%start(n) /= gsmap2%start(n) ) identical = .false. - if (gsmap1%length(n) /= gsmap2%length(n)) identical = .false. - if (gsmap1%pe_loc(n) /= gsmap2%pe_loc(n)) identical = .false. - enddo - endif - - mct_gsmap_Identical = identical - -end function mct_gsmap_Identical - -!=============================================================================== -! !BOP =========================================================================== -! -! !IROUTINE: mct_myindex - binary search for index in list -! -! !DESCRIPTION: -! Do a binary search to see if a value is contained in a list of -! values. return true or false. starti must be monotonically -! increasing, function does NOT check this. -! -! -! !REVISION HISTORY: -! 2007-Jan-17 - T. Craig -- first version -! 2007-Mar-20 - R. Jacob - move to mct_mod -! -! !INTERFACE: ----------------------------------------------------------------- - -logical function mct_myindex(index,starti,counti) - -! !USES: - -! !INPUT/OUTPUT PARAMETERS: - - integer(IN) :: index ! is this index in start/count list - integer(IN) :: starti(:) ! start list - integer(IN) :: counti(:) ! count list - -! !EOP - - !--- local --- - integer(IN) :: nl,nc,nr,ncprev - integer(IN) :: lsize - logical :: stopnow - - !--- formats --- - character(*),parameter :: subName = '(mct_myindex) ' - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - mct_myindex = .false. - - lsize = size(starti) - if (lsize < 1) return - - nl = 0 - nr = lsize + 1 - nc = (nl+nr)/2 - stopnow = .false. - do while (.not.stopnow) - if (index < starti(nc)) then - nr = nc - elseif (index > (starti(nc) + counti(nc) - 1)) then - nl = nc - else - mct_myindex = .true. - return - endif - ncprev = nc - nc = (nl + nr)/2 - if (nc == ncprev .or. nc < 1 .or. nc > lsize) stopnow = .true. - enddo - - mct_myindex = .false. - return - -end function mct_myindex -!=============================================================================== - -end module mct_mod diff --git a/src/shr_mct_mod.F90 b/src/shr_mct_mod.F90 deleted file mode 100644 index d20f69e..0000000 --- a/src/shr_mct_mod.F90 +++ /dev/null @@ -1,860 +0,0 @@ -!=============================================================================== -! SVN $Id: shr_mct_mod.F90 18548 2009-09-26 23:55:51Z tcraig $ -! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_091114/shr/shr_mct_mod.F90 $ -!=============================================================================== -!BOP =========================================================================== -! -! !MODULE: shr_mct_mod -- higher level mct type routines -! needed to prevent some circular dependencies -! -! !REVISION HISTORY: -! 2009-Dec-16 - T. Craig - first prototype -! -! !INTERFACE: ------------------------------------------------------------------ -module shr_mct_mod - -! !USES: - - use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN, CL=>SHR_KIND_CL ! shared kinds - use shr_sys_mod ! share system routines - use shr_mpi_mod ! mpi layer - use shr_const_mod ! constants - use mct_mod - - use shr_log_mod ,only: s_loglev => shr_log_Level - use shr_log_mod ,only: s_logunit => shr_log_Unit - - implicit none - private - -! PUBLIC: Public interfaces - - public :: shr_mct_sMatReadnc - interface shr_mct_sMatPInitnc - module procedure shr_mct_sMatPInitnc_mapfile - end interface - public :: shr_mct_sMatPInitnc - public :: shr_mct_sMatReaddnc - public :: shr_mct_sMatWritednc - public :: shr_mct_queryConfigFile - -!EOP - - !--- local use of kinds --- - - private :: R8, IN, CL - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!=============================================================================== -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: shr_mct_sMatReadnc - read all mapping data from a NetCDF SCRIP file -! in to a full SparseMatrix -! -! !DESCRIPTION: -! Read in mapping matrix data from a SCRIP netCDF data file so a sMat. -! -! !REMARKS: -! Based on cpl_map_read -! -! !REVISION HISTORY: -! 2006 Nov 27: R. Jacob -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine shr_mct_sMatReadnc(sMat,fileName) - - use netcdf - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_sMat),intent(inout) :: sMat - character(*),intent(in) :: filename ! netCDF file to read - -!EOP - - !--- local --- - integer(IN) :: na ! size of source domain - integer(IN) :: nb ! size of destination domain - integer(IN) :: ns ! number of non-zero elements in matrix - integer(IN) :: igrow ! aVect index for matrix row - integer(IN) :: igcol ! aVect index for matrix column - integer(IN) :: iwgt ! aVect index for matrix element - - real(R8) ,allocatable :: rtemp(:) ! reals - integer(IN),allocatable :: itemp(:) ! ints - - integer(IN) :: rcode ! netCDF routine return code - integer(IN) :: fid ! netCDF file ID - integer(IN) :: vid ! netCDF variable ID - integer(IN) :: did ! netCDF dimension ID - - character(*),parameter :: subName = '(shr_mct_sMatReadnc) ' - character(*),parameter :: F00 = "('(shr_mct_sMatReadnc) ',4a)" - character(*),parameter :: F01 = '("(shr_mct_sMatReadnc) ",2(a,i9))' - - if (s_loglev > 0) write(s_logunit,F00) "reading mapping matrix data..." - - !---------------------------------------------------------------------------- - ! open & read the file - !---------------------------------------------------------------------------- - if (s_loglev > 0) write(s_logunit,F00) "* file name : ",trim(fileName) - rcode = nf90_open(filename,NF90_NOWRITE,fid) - if (rcode /= NF90_NOERR) then - write(s_logunit,F00) nf90_strerror(rcode) - call mct_die(subName,"error opening Netcdf file") - endif - - !--- allocate memory & get matrix data ---------- - rcode = nf90_inq_dimid (fid, 'n_s', did) ! size of sparse matrix - rcode = nf90_inquire_dimension(fid, did, len=ns) - rcode = nf90_inq_dimid (fid, 'n_a', did) ! size of input vector - rcode = nf90_inquire_dimension(fid, did, len=na) - rcode = nf90_inq_dimid (fid, 'n_b', did) ! size of output vector - rcode = nf90_inquire_dimension(fid, did, len=nb) - - if (s_loglev > 0) write(s_logunit,F01) "* matrix dimensions src x dst: ",na,' x',nb - if (s_loglev > 0) write(s_logunit,F01) "* number of non-zero elements: ",ns - - !---------------------------------------------------------------------------- - ! init the mct sMat data type - !---------------------------------------------------------------------------- - ! mct_sMat_init must be given the number of rows and columns that - ! would be in the full matrix. Nrows= size of output vector=nb. - ! Ncols = size of input vector = na. - call mct_sMat_init(sMat, nb, na, ns) - - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - - !!!!!!!!!!!!!!!!!!!!!!!!!! - ! read and load matrix weights - allocate(rtemp(ns),stat=rcode) - if (rcode /= 0) & - call mct_die(subName,':: allocate weights',rcode) - - rcode = nf90_inq_varid(fid, 'S',vid) - rcode = nf90_get_var(fid, vid, rtemp) - if (rcode /= NF90_NOERR .and. s_loglev > 0) then - write(s_logunit,F00) nf90_strerror(rcode) - end if - - sMat%data%rAttr(iwgt ,:) = rtemp(:) - - deallocate(rtemp, stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: deallocate weights',rcode) - - !!!!!!!!!!!!!!!!!!!!!!!!!! - ! read and load rows - allocate(itemp(ns),stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate rows',rcode) - - rcode = nf90_inq_varid(fid, 'row', vid) - rcode = nf90_get_var(fid, vid, itemp) - if (rcode /= NF90_NOERR .and. s_loglev > 0) then - write(s_logunit,F00) nf90_strerror(rcode) - end if - - sMat%data%iAttr(igrow,:) = itemp(:) - - - !!!!!!!!!!!!!!!!!!!!!!!!!! - ! read and load columns - itemp(:) = 0 - - rcode = nf90_inq_varid(fid, 'col', vid) - rcode = nf90_get_var(fid, vid, itemp) - if (rcode /= NF90_NOERR .and. s_loglev > 0) then - write(s_logunit,F00) nf90_strerror(rcode) - end if - - sMat%data%iAttr(igcol,:) = itemp(:) - - deallocate(itemp, stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: deallocate cols',rcode) - - rcode = nf90_close(fid) - - if (s_loglev > 0) write(s_logunit,F00) "... done reading file" - call shr_sys_flush(s_logunit) - -end subroutine shr_mct_sMatReadnc - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: shr_mct_queryConfigFile - get mct config file info -! -! !DESCRIPTION: -! Query MCT config file variables -! -! !REMARKS: -! -! !REVISION HISTORY: -! 2013 Aug 17: T. Craig -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine shr_mct_queryConfigFile(mpicom, ConfigFileName, & - Label1,Value1,Label2,Value2,Label3,Value3) - -! !INPUT/OUTPUT PARAMETERS: - integer ,intent(in) :: mpicom - character(len=*), intent(in) :: ConfigFileName - character(len=*), intent(in) :: Label1 - character(len=*), intent(out) :: Value1 - character(len=*), intent(in) ,optional :: Label2 - character(len=*), intent(out),optional :: Value2 - character(len=*), intent(in) ,optional :: Label3 - character(len=*), intent(out),optional :: Value3 - -!EOP - integer :: iret - character(*),parameter :: subName = '(shr_mct_queryConfigFile) ' - - call I90_allLoadF(ConfigFileName,0,mpicom,iret) - if(iret /= 0) then - write(s_logunit,*) trim(subname),"Cant find config file ",ConfigFileName - call shr_sys_abort(trim(subname)//' File Not Found') - endif - - call i90_label(trim(Label1),iret) - if(iret /= 0) then - write(s_logunit,*) trim(subname),"Cant find label ",Label1 - call shr_sys_abort(trim(subname)//' Label1 Not Found') - endif - - call i90_gtoken(Value1,iret) - if(iret /= 0) then - write(s_logunit,*) trim(subname),"Error reading token ",Value1 - call shr_sys_abort(trim(subname)//' Error on read value1') - endif - - if (present(Label2) .and. present(Value2)) then - - call i90_label(trim(Label2),iret) - if(iret /= 0) then - write(s_logunit,*) trim(subname),"Cant find label ",Label2 - call shr_sys_abort(trim(subname)//' Label2 Not Found') - endif - - call i90_gtoken(Value2,iret) - if(iret /= 0) then - write(s_logunit,*)"Error reading token ",Value2 - call shr_sys_abort(trim(subname)//' Error on read value2') - endif - - endif - - if (present(Label3) .and. present(Value3)) then - - call i90_label(trim(Label3),iret) - if(iret /= 0) then - write(s_logunit,*) trim(subname),"Cant find label ",Label3 - call shr_sys_abort(trim(subname)//' Label3 Not Found') - endif - - call i90_gtoken(Value3,iret) - if(iret /= 0) then - write(s_logunit,*)"Error reading token ",Value3 - call shr_sys_abort(trim(subname)//' Error on read value3') - endif - - endif - - call I90_Release(iret) - -end subroutine shr_mct_queryConfigFile - -!=============================================================================== -!BOP =========================================================================== -! -! !IROUTINE: shr_mct_sMatPInitnc_mapfile - initialize a SparseMatrixPlus. -! -! !DESCRIPTION: -! Read in mapping matrix data from a SCRIP netCDF data file in first an -! Smat and then an SMatPlus -! -! !REMARKS: -! -! !REVISION HISTORY: -! 2012 Feb 27: M. Vertenstein -! -! !INTERFACE: ------------------------------------------------------------------ - -subroutine shr_mct_sMatPInitnc_mapfile(sMatP, gsMapX, gsMapY, & - filename, maptype, mpicom, & - ni_i, nj_i, ni_o, nj_o, & - areasrc, areadst) - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_sMatP),intent(inout) :: sMatP - type(mct_gsMap),intent(in) :: gsMapX - type(mct_gsMap),intent(in) :: gsMapY - character(*) ,intent(in) :: filename ! scrip map file to read - character(*) ,intent(in) :: maptype ! map type - integer ,intent(in) :: mpicom - integer ,intent(out), optional :: ni_i ! number of longitudes on input grid - integer ,intent(out), optional :: nj_i ! number of latitudes on input grid - integer ,intent(out), optional :: ni_o ! number of longitudes on output grid - integer ,intent(out), optional :: nj_o ! number of latitudes on output grid - type(mct_Avect),intent(out), optional :: areasrc ! area of src grid from mapping file - type(mct_Avect),intent(out), optional :: areadst ! area of src grid from mapping file - -!EOP - type(mct_sMat ) :: sMati ! initial sMat from read (either root or decomp) - type(mct_Avect) :: areasrc_map ! area of src grid from mapping file - type(mct_Avect) :: areadst_map ! area of dst grid from mapping file - - integer :: lsize - integer :: pe_loc - logical :: usevector - character(len=3) :: Smaptype - character(*),parameter :: areaAV_field = 'aream' - character(*),parameter :: F00 = "('(shr_mct_sMatPInitnc) ',4a)" - character(*),parameter :: F01 = "('(shr_mct_sMatPInitnc) ',a,i10)" - - call shr_mpi_commrank(mpicom,pe_loc) - - if (s_loglev > 0) write(s_logunit,*) " " - if (s_loglev > 0) write(s_logunit,F00) "Initializing SparseMatrixPlus" - if (s_loglev > 0) write(s_logunit,F00) "SmatP mapname ",trim(filename) - if (s_loglev > 0) write(s_logunit,F00) "SmatP maptype ",trim(maptype) - - if (maptype == "X") then - Smaptype = "src" - else if(maptype == "Y") then - Smaptype = "dst" - end if - - call shr_mpi_commrank(mpicom, pe_loc) - - lsize = mct_gsMap_lsize(gsMapX, mpicom) - call mct_aVect_init(areasrc_map, rList=areaAV_field, lsize=lsize) - - lsize = mct_gsMap_lsize(gsMapY, mpicom) - call mct_aVect_init(areadst_map, rList=areaAV_field, lsize=lsize) - - if (present(ni_i) .and. present(nj_i) .and. present(ni_o) .and. present(nj_o)) then - call shr_mct_sMatReaddnc(sMati, gsMapX, gsMapY, Smaptype, areasrc_map, areadst_map, & - fileName, pe_loc, mpicom, ni_i, nj_i, ni_o, nj_o) - else - call shr_mct_sMatReaddnc(sMati, gsMapX, gsMapY, Smaptype, areasrc_map, areadst_map, & - fileName, pe_loc, mpicom) - end if - call mct_sMatP_Init(sMatP, sMati, gsMapX, gsMapY, 0, mpicom, gsMapX%comp_id) - -#ifdef CPP_VECTOR - !--- initialize the vector parts of the sMat --- - call mct_sMatP_Vecinit(sMatP) -#endif - - lsize = mct_smat_gNumEl(sMatP%Matrix,mpicom) - if (s_loglev > 0) write(s_logunit,F01) "Done initializing SmatP, nElements = ",lsize - -#ifdef CPP_VECTOR - usevector = .true. -#else - usevector = .false. -#endif - if (present(areasrc)) then - call mct_aVect_copy(aVin=areasrc_map, aVout=areasrc, vector=usevector) - end if - if (present(areadst)) then - call mct_aVect_copy(aVin=areadst_map, aVout=areadst, vector=usevector) - end if - - call mct_aVect_clean(areasrc_map) - call mct_aVect_clean(areadst_map) - - call mct_sMat_Clean(sMati) - -end subroutine shr_mct_sMatPInitnc_mapfile - -!BOP =========================================================================== -! -! !IROUTINE: shr_mct_sMatReaddnc - Do a distributed read of a NetCDF SCRIP file and -! return weights in a distributed SparseMatrix -! -! !DESCRIPTION: -! Read in mapping matrix data from a SCRIP netCDF data file using -! a low memory method and then scatter to all pes. -! -! !REMARKS: -! This routine leverages gsmaps to determine scatter pattern -! The scatter is implemented as a bcast of all weights then a local -! computation on each pe to determine with weights to keep based -! on gsmap information. -! The algorithm to determine whether a weight belongs on a pe involves -! creating a couple local arrays (lsstart and lscount) which are -! the local values of start and length from the gsmap. these are -! sorted via a bubble sort and then searched via a binary search -! to check whether a global index is on the local pe. -! The local buffer sizes are estimated up front based on ngridcell/npes -! plus 20% (see 1.2 below). If the local buffer size fills up, then -! the buffer is reallocated 50% large (see 1.5 below) and the fill -! continues. The idea is to trade off memory reallocation and copy -! with memory usage. 1.2 and 1.5 are arbitary, other values may -! result in better performance. -! Once all the matrix weights have been read, the sMat is initialized, -! the values from the buffers are copied in, and everything is deallocated. - -! !SEE ALSO: -! mct/m_SparseMatrix.F90 (MCT source code) -! -! !REVISION HISTORY: -! 2007-Jan-18 - T. Craig -- first version -! 2007-Mar-20 - R. Jacob -- rename to shr_mct_sMatReaddnc. Remove use of cpl_ -! variables and move to shr_mct_mod -! -! !INTERFACE: ----------------------------------------------------------------- - -subroutine shr_mct_sMatReaddnc(sMat,SgsMap,DgsMap,newdom,areasrc,areadst, & - fileName,mytask, mpicom, ni_i,nj_i,ni_o,nj_o ) - -! !USES: - - use netcdf - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_sMat) ,intent(out) :: sMat ! mapping data - type(mct_gsMap) ,intent(in) ,target :: SgsMap ! src gsmap - type(mct_gSMap) ,intent(in) ,target :: DgsMap ! dst gsmap - character(*) ,intent(in) :: newdom ! type of sMat (src or dst) - type(mct_Avect) ,intent(out), optional :: areasrc ! area of src grid from mapping file - type(mct_Avect) ,intent(out), optional :: areadst ! area of dst grid from mapping file - character(*) ,intent(in) :: filename! netCDF file to read - integer(IN) ,intent(in) :: mytask ! processor id - integer(IN) ,intent(in) :: mpicom ! communicator - integer(IN) ,intent(out), optional :: ni_i ! number of lons on input grid - integer(IN) ,intent(out), optional :: nj_i ! number of lats on input grid - integer(IN) ,intent(out), optional :: ni_o ! number of lons on output grid - integer(IN) ,intent(out), optional :: nj_o ! number of lats on output grid - -! !EOP - - !--- local --- - integer(IN) :: n,m ! generic loop indicies - integer(IN) :: na ! size of source domain - integer(IN) :: nb ! size of destination domain - integer(IN) :: ns ! number of non-zero elements in matrix - integer(IN) :: igrow ! aVect index for matrix row - integer(IN) :: igcol ! aVect index for matrix column - integer(IN) :: iwgt ! aVect index for matrix element - integer(IN) :: rsize ! size of read buffer - integer(IN) :: cnt ! local num of wgts - integer(IN) :: cntold ! local num of wgts, previous read - integer(IN) :: start(1)! netcdf read - integer(IN) :: count(1)! netcdf read - integer(IN) :: bsize ! buffer size - integer(IN) :: nread ! number of reads - logical :: mywt ! does this weight belong on my pe - - !--- buffers for i/o --- - real(R8) ,allocatable :: Sbuf(:) ! real weights - integer(IN),allocatable :: Rbuf(:) ! ints rows - integer(IN),allocatable :: Cbuf(:) ! ints cols - - !--- variables associated with local computation of global indices - integer(IN) :: lsize ! size of local seg map - integer(IN) :: commsize ! size of local communicator - integer(IN),allocatable :: lsstart(:) ! local seg map info - integer(IN),allocatable :: lscount(:) ! local seg map info - type(mct_gsMap),pointer :: mygsmap ! pointer to one of the gsmaps - integer(IN) :: l1,l2 ! generice indices for sort - logical :: found ! for sort - - !--- variable assocaited with local data buffers and reallocation - real(R8) ,allocatable :: Snew(:),Sold(:) ! reals - integer(IN),allocatable :: Rnew(:),Rold(:) ! ints - integer(IN),allocatable :: Cnew(:),Cold(:) ! ints - - integer(IN) :: rcode ! netCDF routine return code - integer(IN) :: fid ! netCDF file ID - integer(IN) :: vid ! netCDF variable ID - integer(IN) :: did ! netCDF dimension ID - !--- arbitrary size of read buffer, this is the chunk size weights reading - integer(IN),parameter :: rbuf_size = 100000 - - !--- global source and destination areas --- - type(mct_Avect) :: areasrc0 ! area of src grid from mapping file - type(mct_Avect) :: areadst0 ! area of src grid from mapping file - - character(*),parameter :: areaAV_field = 'aream' - - !--- formats --- - character(*),parameter :: subName = '(shr_mct_sMatReaddnc) ' - character(*),parameter :: F00 = '("(shr_mct_sMatReaddnc) ",4a)' - character(*),parameter :: F01 = '("(shr_mct_sMatReaddnc) ",2(a,i10))' - -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - - call shr_mpi_commsize(mpicom,commsize) - if (mytask == 0) then - if (s_loglev > 0) write(s_logunit,F00) "reading mapping matrix data decomposed..." - - !---------------------------------------------------------------------------- - ! open & read the file - !---------------------------------------------------------------------------- - if (s_loglev > 0) write(s_logunit,F00) "* file name : ",trim(fileName) - rcode = nf90_open(filename,NF90_NOWRITE,fid) - if (rcode /= NF90_NOERR) then - print *,'Failed to open file ',trim(filename) - call shr_sys_abort(trim(subName)//nf90_strerror(rcode)) - end if - - - !--- get matrix dimensions ---------- - rcode = nf90_inq_dimid(fid, 'n_s', did) ! size of sparse matrix - rcode = nf90_inquire_dimension(fid, did, len=ns) - rcode = nf90_inq_dimid(fid, 'n_a', did) ! size of input vector - rcode = nf90_inquire_dimension(fid, did, len=na) - rcode = nf90_inq_dimid(fid, 'n_b', did) ! size of output vector - rcode = nf90_inquire_dimension(fid, did, len=nb) - - if (present(ni_i) .and. present(nj_i) .and. present(ni_o) .and. present(nj_o)) then - rcode = nf90_inq_dimid(fid, 'ni_a', did) ! number of lons in input grid - rcode = nf90_inquire_dimension(fid, did, len=ni_i) - rcode = nf90_inq_dimid(fid, 'nj_a', did) ! number of lats in input grid - rcode = nf90_inquire_dimension(fid, did, len=nj_i) - rcode = nf90_inq_dimid(fid, 'ni_b', did) ! number of lons in output grid - rcode = nf90_inquire_dimension(fid, did, len=ni_o) - rcode = nf90_inq_dimid(fid, 'nj_b', did) ! number of lats in output grid - rcode = nf90_inquire_dimension(fid, did, len=nj_o) - end if - - if (s_loglev > 0) write(s_logunit,F01) "* matrix dims src x dst : ",na,' x',nb - if (s_loglev > 0) write(s_logunit,F01) "* number of non-zero elements: ",ns - - endif - - !--- read and load area_a --- - if (present(areasrc)) then - if (mytask == 0) then - call mct_aVect_init(areasrc0,' ',areaAV_field,na) - rcode = nf90_inq_varid(fid, 'area_a', vid) - if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) - rcode = nf90_get_var(fid, vid, areasrc0%rAttr) - if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) - endif - call mct_aVect_scatter(areasrc0, areasrc, SgsMap, 0, mpicom, rcode) - if (rcode /= 0) call mct_die("shr_mct_sMatReaddnc","Error on scatter of areasrc0") - if (mytask == 0) then -! if (present(dbug)) then -! if (dbug > 2) then -! write(6,*) subName,'Size of src ',mct_aVect_lSize(areasrc0) -! write(6,*) subName,'min/max src ',minval(areasrc0%rAttr(1,:)),maxval(areasrc0%rAttr(1,:)) -! endif -! end if - call mct_aVect_clean(areasrc0) - end if - end if - - !--- read and load area_b --- - if (present(areadst)) then - if (mytask == 0) then - call mct_aVect_init(areadst0,' ',areaAV_field,nb) - rcode = nf90_inq_varid(fid, 'area_b', vid) - if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) - rcode = nf90_get_var(fid, vid, areadst0%rAttr) - if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) - endif - call mct_aVect_scatter(areadst0, areadst, DgsMap, 0, mpicom, rcode) - if (rcode /= 0) call mct_die("shr_mct_sMatReaddnc","Error on scatter of areadst0") - if (mytask == 0) then -! if (present(dbug)) then -! if (dbug > 2) then -! write(6,*) subName,'Size of dst ',mct_aVect_lSize(areadst0) -! write(6,*) subName,'min/max dst ',minval(areadst0%rAttr(1,:)),maxval(areadst0%rAttr(1,:)) -! endif -! end if - call mct_aVect_clean(areadst0) - endif - endif - - if (present(ni_i) .and. present(nj_i) .and. present(ni_o) .and. present(nj_o)) then - call shr_mpi_bcast(ni_i,mpicom,subName//" MPI in ni_i bcast") - call shr_mpi_bcast(nj_i,mpicom,subName//" MPI in nj_i bcast") - call shr_mpi_bcast(ni_o,mpicom,subName//" MPI in ni_o bcast") - call shr_mpi_bcast(nj_o,mpicom,subName//" MPI in nj_o bcast") - end if - - call shr_mpi_bcast(ns,mpicom,subName//" MPI in ns bcast") - call shr_mpi_bcast(na,mpicom,subName//" MPI in na bcast") - call shr_mpi_bcast(nb,mpicom,subName//" MPI in nb bcast") - - !--- setup local seg map, sorted - if (newdom == 'src') then - mygsmap => DgsMap - elseif (newdom == 'dst') then - mygsmap => SgsMap - else - write(s_logunit,F00) 'ERROR: invalid newdom value = ',newdom - call shr_sys_abort(trim(subName)//" invalid newdom value") - endif - lsize = 0 - do n = 1,size(mygsmap%start) - if (mygsmap%pe_loc(n) == mytask) then - lsize=lsize+1 - endif - enddo - allocate(lsstart(lsize),lscount(lsize),stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate Lsstart',rcode) - - lsize = 0 - do n = 1,size(mygsmap%start) - if (mygsmap%pe_loc(n) == mytask) then ! on my pe - lsize=lsize+1 - found = .false. - l1 = 1 - do while (.not.found .and. l1 < lsize) ! bubble sort copy - if (mygsmap%start(n) < lsstart(l1)) then - do l2 = lsize, l1+1, -1 - lsstart(l2) = lsstart(l2-1) - lscount(l2) = lscount(l2-1) - enddo - found = .true. - else - l1 = l1 + 1 - endif - enddo - lsstart(l1) = mygsmap%start(n) - lscount(l1) = mygsmap%length(n) - endif - enddo - do n = 1,lsize-1 - if (lsstart(n) > lsstart(n+1)) then - write(s_logunit,F00) ' ERROR: lsstart not properly sorted' - call shr_sys_abort() - endif - enddo - - rsize = min(rbuf_size,ns) ! size of i/o chunks - bsize = ((ns/commsize) + 1 ) * 1.2 ! local temporary buffer size - if (ns == 0) then - nread = 0 - else - nread = (ns-1)/rsize + 1 ! num of reads to do - endif - - allocate(Sbuf(rsize),Rbuf(rsize),Cbuf(rsize),stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate Sbuf',rcode) - allocate(Snew(bsize),Cnew(bsize),Rnew(bsize),stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate Snew1',rcode) - - cnt = 0 - do n = 1,nread - start(1) = (n-1)*rsize + 1 - count(1) = min(rsize,ns-start(1)+1) - - !--- read data on root pe - if (mytask== 0) then - rcode = nf90_inq_varid(fid, 'S', vid) - rcode = nf90_get_var(fid, vid, Sbuf, start, count) - if (rcode /= NF90_NOERR .and. s_loglev > 0) then - write(s_logunit,F00) nf90_strerror(rcode) - end if - - rcode = nf90_inq_varid(fid, 'row', vid) - rcode = nf90_get_var(fid, vid, Rbuf, start, count) - if (rcode /= NF90_NOERR .and. s_loglev > 0) then - write(s_logunit,F00) nf90_strerror(rcode) - end if - - rcode = nf90_inq_varid(fid, 'col', vid) - rcode = nf90_get_var(fid, vid, Cbuf, start, count) - if (rcode /= NF90_NOERR .and. s_loglev > 0) then - write(s_logunit,F00) nf90_strerror(rcode) - end if - endif - - !--- send S, row, col to all pes - call shr_mpi_bcast(Sbuf,mpicom,subName//" MPI in Sbuf bcast") - call shr_mpi_bcast(Rbuf,mpicom,subName//" MPI in Rbuf bcast") - call shr_mpi_bcast(Cbuf,mpicom,subName//" MPI in Cbuf bcast") - - !--- now each pe keeps what it should - do m = 1,count(1) - !--- should this weight be on my pe - if (newdom == 'src') then - mywt = mct_myindex(Rbuf(m),lsstart,lscount) - elseif (newdom == 'dst') then - mywt = mct_myindex(Cbuf(m),lsstart,lscount) - endif - - if (mywt) then - cntold = cnt - cnt = cnt + 1 - - !--- new arrays need to be bigger - if (cnt > bsize) then - !--- allocate old arrays and copy new into old - allocate(Sold(cntold),Rold(cntold),Cold(cntold),stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate old',rcode) - Sold(1:cntold) = Snew(1:cntold) - Rold(1:cntold) = Rnew(1:cntold) - Cold(1:cntold) = Cnew(1:cntold) - - !--- reallocate new to bigger size, increase buffer by 50% (arbitrary) - deallocate(Snew,Rnew,Cnew,stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate new',rcode) - bsize = 1.5 * bsize - if (s_loglev > 1) write(s_logunit,F01) ' reallocate bsize to ',bsize - allocate(Snew(bsize),Rnew(bsize),Cnew(bsize),stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: allocate old',rcode) - - !--- copy data back into new - Snew(1:cntold) = Sold(1:cntold) - Rnew(1:cntold) = Rold(1:cntold) - Cnew(1:cntold) = Cold(1:cntold) - deallocate(Sold,Rold,Cold,stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: deallocate old',rcode) - endif - - Snew(cnt) = Sbuf(m) - Rnew(cnt) = Rbuf(m) - Cnew(cnt) = Cbuf(m) - endif - enddo ! count - enddo ! nread - - deallocate(Sbuf,Rbuf,Cbuf, stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: deallocate Sbuf',rcode) - - !---------------------------------------------------------------------------- - ! init the mct sMat data type - !---------------------------------------------------------------------------- - ! mct_sMat_init must be given the number of rows and columns that - ! would be in the full matrix. Nrows= size of output vector=nb. - ! Ncols = size of input vector = na. - call mct_sMat_init(sMat, nb, na, cnt) - - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - - if (cnt /= 0) then - sMat%data%rAttr(iwgt ,1:cnt) = Snew(1:cnt) - sMat%data%iAttr(igrow,1:cnt) = Rnew(1:cnt) - sMat%data%iAttr(igcol,1:cnt) = Cnew(1:cnt) - endif - deallocate(Snew,Rnew,Cnew, stat=rcode) - deallocate(lsstart,lscount,stat=rcode) - if (rcode /= 0) call mct_perr_die(subName,':: deallocate new',rcode) - - if (mytask == 0) then - rcode = nf90_close(fid) - if (s_loglev > 0) write(s_logunit,F00) "... done reading file" - call shr_sys_flush(s_logunit) - endif - -end subroutine shr_mct_sMatReaddnc - -!BOP =========================================================================== -! -! !IROUTINE: shr_mct_sMatWritednc - Do a distributed write of a NetCDF SCRIP file -! based on a distributed SparseMatrix -! -! !DESCRIPTION: -! Write out mapping matrix data from a SCRIP netCDF data file using -! a low memory method. -! -! !SEE ALSO: -! mct/m_SparseMatrix.F90 (MCT source code) -! -! !REVISION HISTORY: -! 2009-Dec-15 - T. Craig -- first version -! -! !INTERFACE: ----------------------------------------------------------------- - -subroutine shr_mct_sMatWritednc(sMat,iosystem, io_type, io_format, fileName,compid, mpicom) - -! !USES: - use pio, only : iosystem_desc_t - use shr_pcdf_mod, only : shr_pcdf_readwrite - implicit none -#include - -! !INPUT/OUTPUT PARAMETERS: - - type(mct_sMat) ,intent(in) :: sMat ! mapping data - type(iosystem_desc_t) :: iosystem ! PIO subsystem description - integer(IN) ,intent(in) :: io_type ! type of io interface for this file - integer(IN) ,intent(in) :: io_format ! type of io netcdf3 format for this file - character(*) ,intent(in) :: filename ! netCDF file to read - integer(IN) ,intent(in) :: compid ! processor id - integer(IN) ,intent(in) :: mpicom ! communicator - - ! !local - integer(IN) :: na,nb,ns,lsize,npes,ierr,my_task,n - integer(IN), pointer :: start(:),count(:),ssize(:),pe_loc(:) - integer(IN), pointer :: expvari(:) - real(R8) , pointer :: expvarr(:) - type(mct_gsmap) :: gsmap - type(mct_avect) :: AV - character(*),parameter :: subName = '(shr_mct_sMatWritednc) ' - -!---------------------------------------- - - call MPI_COMM_SIZE(mpicom,npes,ierr) - call MPI_COMM_RANK(mpicom,my_task,ierr) - allocate(start(npes),count(npes),ssize(npes),pe_loc(npes)) - - na = mct_sMat_ncols(sMat) - nb = mct_sMat_nrows(sMat) - ns = mct_sMat_gNumEl(sMat,mpicom) - lsize = mct_sMat_lsize(sMat) - - count(:) = -999 - pe_loc(:) = -999 - ssize(:) = 1 - call MPI_GATHER(lsize,1,MPI_INTEGER,count,ssize,MPI_INTEGER,0,mpicom,ierr) - - if (my_task == 0) then - if (minval(count) < 0) then - call shr_sys_abort(subname//' ERROR: count invalid') - endif - - start(1) = 1 - pe_loc(1) = 0 - do n = 2,npes - start(n) = start(n-1)+count(n-1) - pe_loc(n) = n-1 - enddo - - endif - - call mct_gsmap_init(gsmap,npes,start,count,pe_loc,0,mpicom,compid,ns) - deallocate(start,count,ssize,pe_loc) - - call mct_aVect_init(AV,iList='row:col',rList='S',lsize=lsize) - allocate(expvari(lsize)) - call mct_sMat_ExpGRowI(sMat,expvari) - AV%iAttr(1,:) = expvari(:) - call mct_sMat_ExpGColI(sMat,expvari) - AV%iAttr(2,:) = expvari(:) - deallocate(expvari) - allocate(expvarr(lsize)) - call mct_sMat_ExpMatrix(sMat,expvarr) - AV%rAttr(1,:) = expvarr(:) - deallocate(expvarr) - - call shr_pcdf_readwrite('write',iosystem,io_type, trim(filename),mpicom,gsmap,clobber=.false.,io_format=io_format, & - id1=na,id1n='n_a',id2=nb,id2n='n_b',id3=ns,id3n='n_s',av1=AV,av1n='') - - call mct_gsmap_clean(gsmap) - call mct_avect_clean(AV) - -end subroutine shr_mct_sMatWritednc -!=============================================================================== - -end module shr_mct_mod diff --git a/src/shr_pcdf_mod.F90 b/src/shr_pcdf_mod.F90 deleted file mode 100644 index 2d066d0..0000000 --- a/src/shr_pcdf_mod.F90 +++ /dev/null @@ -1,817 +0,0 @@ -!=============================================================================== -! SVN $Id: shr_pcdf_mod.F90 18683 2009-09-30 22:20:22Z kauff $ -! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/drv/seq_mct/trunk_tags/drvseq3_0_36/driver/shr_pcdf_mod.F90 $ -!=============================================================================== -!BOP =========================================================================== -! -! !MODULE: shr_pcdf_mod -- generic pio file reader and writer -! -! !DESCRIPTION: -! -! Reads & writes pio files -! -! !REMARKS: -! -! supports aVect, 1d real and integer, and scalar real and integer fields -! using a common decomp for all fields. this is a heavily overloaded interface -! that supports read and write of multiple fields/type to a file using a single call. -! -! !REVISION HISTORY: -! 2009-Oct-15 - T. Craig - initial implementation -! -! !INTERFACE: ------------------------------------------------------------------ - -module shr_pcdf_mod - - use shr_kind_mod, only: R8 => SHR_KIND_R8, IN => SHR_KIND_IN - use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS - use shr_sys_mod, only: shr_sys_abort, shr_sys_flush - use shr_const_mod, only: shr_const_spval - use shr_log_mod, only: shr_log_unit, shr_log_level - use mct_mod - use pio - - implicit none - - private - - !PUBLIC TYPES: - - ! no public types - -!!PUBLIC MEMBER FUNCTIONS - - public :: shr_pcdf_readwrite - -!!PUBLIC DATA MEMBERS: - - ! no public data - -!EOP - - character(len=*),parameter :: version = 'shr_pcdf_v0_0_01' - real(r8) ,parameter :: fillvalue = SHR_CONST_SPVAL - integer(in) ,parameter :: ifillvalue = -999999 - -!=============================================================================== -contains -!=============================================================================== -subroutine shr_pcdf_readwrite(type,iosystem,pio_iotype,filename,& - mpicom,gsmap,dof,clobber,io_format, & - id1,id1n,rs1,rs1n,is1,is1n,rf1,rf1n,if1,if1n,av1,av1n, & - id2,id2n,rs2,rs2n,is2,is2n,rf2,rf2n,if2,if2n,av2,av2n, & - id3,id3n,rs3,rs3n,is3,is3n,rf3,rf3n,if3,if3n,av3,av3n, & - id4,id4n,rs4,rs4n,is4,is4n,rf4,rf4n,if4,if4n,av4,av4n ) - use pio, only : iosystem_desc_t - implicit none - - character(len=*) , intent(in) :: type ! 'read' or 'write' - type(iosystem_desc_t), intent(inout), target :: iosystem - integer(IN), intent(in) :: pio_iotype - character(len=*) , intent(in) :: filename ! filename - integer(IN) , intent(in) :: mpicom ! mpicom - - !--- one of these must be set --- - type(mct_gsmap) , optional, intent(in) :: gsmap ! decomp for all data - integer(IN) , optional, intent(in) :: dof(:) ! decomp for all data - - !--- optional settings --- - logical , optional, intent(in) :: clobber - integer(IN), optional, intent(in) :: io_format - - ! add root, stride, ntasks, netcdf/pnetcdf, etc - - !--- data to write --- - - !--- single scalar dimensions, assumed valid on the io root pe --- - integer(IN) , optional, intent(inout) :: id1 ! int field 1 - character(len=*) , optional, intent(in) :: id1n ! if1 name - integer(IN) , optional, intent(inout) :: id2 ! int field 2 - character(len=*) , optional, intent(in) :: id2n ! if2 name - integer(IN) , optional, intent(inout) :: id3 ! int field 3 - character(len=*) , optional, intent(in) :: id3n ! if3 name - integer(IN) , optional, intent(inout) :: id4 ! int field 4 - character(len=*) , optional, intent(in) :: id4n ! if4 name - - !--- single scalar variables, assumed valid on the io root pe --- - real(R8) , optional, intent(inout) :: rs1 ! real field 1 - character(len=*) , optional, intent(in) :: rs1n ! rf1 name - real(R8) , optional, intent(inout) :: rs2 ! real field 2 - character(len=*) , optional, intent(in) :: rs2n ! rf2 name - real(R8) , optional, intent(inout) :: rs3 ! real field 3 - character(len=*) , optional, intent(in) :: rs3n ! rf3 name - real(R8) , optional, intent(inout) :: rs4 ! real field 4 - character(len=*) , optional, intent(in) :: rs4n ! rf4 name - integer(IN) , optional, intent(inout) :: is1 ! int field 1 - character(len=*) , optional, intent(in) :: is1n ! if1 name - integer(IN) , optional, intent(inout) :: is2 ! int field 2 - character(len=*) , optional, intent(in) :: is2n ! if2 name - integer(IN) , optional, intent(inout) :: is3 ! int field 3 - character(len=*) , optional, intent(in) :: is3n ! if3 name - integer(IN) , optional, intent(inout) :: is4 ! int field 4 - character(len=*) , optional, intent(in) :: is4n ! if4 name - - !--- single field, decomposed f90 data in 1d arrays --- - real(R8) , optional, intent(inout) :: rf1(:) ! real field 1 - character(len=*) , optional, intent(in) :: rf1n ! rf1 name - real(R8) , optional, intent(inout) :: rf2(:) ! real field 2 - character(len=*) , optional, intent(in) :: rf2n ! rf2 name - real(R8) , optional, intent(inout) :: rf3(:) ! real field 3 - character(len=*) , optional, intent(in) :: rf3n ! rf3 name - real(R8) , optional, intent(inout) :: rf4(:) ! real field 4 - character(len=*) , optional, intent(in) :: rf4n ! rf4 name - integer(IN) , optional, intent(inout) :: if1(:) ! int field 1 - character(len=*) , optional, intent(in) :: if1n ! if1 name - integer(IN) , optional, intent(inout) :: if2(:) ! int field 2 - character(len=*) , optional, intent(in) :: if2n ! if2 name - integer(IN) , optional, intent(inout) :: if3(:) ! int field 3 - character(len=*) , optional, intent(in) :: if3n ! if3 name - integer(IN) , optional, intent(inout) :: if4(:) ! int field 4 - character(len=*) , optional, intent(in) :: if4n ! if4 name - - !--- attr vect, decomposed f90 data in av datatype --- - type(mct_aVect) , optional, intent(inout) :: av1 ! avect 1 - character(len=*) , optional, intent(in) :: av1n ! av1 name - type(mct_aVect) , optional, intent(inout) :: av2 ! avect 2 - character(len=*) , optional, intent(in) :: av2n ! av2 name - type(mct_aVect) , optional, intent(inout) :: av3 ! avect 3 - character(len=*) , optional, intent(in) :: av3n ! av3 name - type(mct_aVect) , optional, intent(inout) :: av4 ! avect 4 - character(len=*) , optional, intent(in) :: av4n ! av4 name - - !--- local --- - integer(IN) :: iam,ntasks - integer(IN) :: ier,rcode - integer(IN) :: loop,minloop,maxloop - integer(IN) :: n,nf - logical :: readtype - integer(IN) :: lsize,gsize - logical :: lclobber - integer :: lio_format - logical :: exists - integer :: nmode - character(CL) :: fname - character(CL) :: vname - type(mct_string) :: mstring ! mct char type - integer(IN) :: dimid1(1) - - - type(file_desc_t) :: fid - type(io_desc_t) :: iodescd - type(io_desc_t) :: iodesci - integer(IN), pointer :: ldof(:) - - character(len=*),parameter :: subname = '(shr_pcdf_readwrite) ' - - !------------- - - if (trim(type) == 'read') then - readtype = .true. - elseif (trim(type) == 'write') then - readtype = .false. - else - call shr_sys_abort(subname//' ERROR: read write type invalid') - endif - - lclobber = .false. - if (present(clobber)) lclobber=clobber - - lio_format = PIO_64BIT_OFFSET - if (present(io_format)) lio_format=io_format - - call mpi_comm_size(mpicom,ntasks,ier) - call mpi_comm_rank(mpicom,iam,ier) - - if (iam == 0) then - write(shr_log_unit,*) subname,' filename = ',trim(filename) - write(shr_log_unit,*) subname,' type = ',trim(type) - write(shr_log_unit,*) subname,' clobber = ',lclobber - write(shr_log_unit,*) subname,' io_format = ',lio_format - call shr_sys_flush(shr_log_unit) - endif - - if (present(gsmap) .and. present(dof)) then - call shr_sys_abort(trim(subname)//' ERROR: either gsmap OR dof must be an argument') - endif - if (present(gsmap)) then - lsize = mct_gsmap_lsize(gsmap,mpicom) - gsize = mct_gsmap_gsize(gsmap) - call mct_gsmap_OrderedPoints(gsmap, iam, ldof) - call pio_initdecomp(iosystem, pio_double, (/gsize/), ldof, iodescd) - call pio_initdecomp(iosystem, pio_int , (/gsize/), ldof, iodesci) - deallocate(ldof) - elseif (present(dof)) then - lsize = size(dof) - call shr_mpi_sum(lsize,gsize,mpicom,string=trim(subname),all=.true.) - call pio_initdecomp(iosystem, pio_double, (/gsize/), ldof, iodescd) - call pio_initdecomp(iosystem, pio_int , (/gsize/), ldof, iodesci) - else - call shr_sys_abort(trim(subname)//' ERROR: either gsmap OR dof must be an argument') - endif - - if (iam == 0) then - if (len_trim(filename) == 0) then - call shr_sys_abort(trim(subname)//' ERROR: filename is empty') - endif - inquire(file=trim(filename),exist=exists) - endif - call shr_mpi_bcast(exists,mpicom,trim(subname)//' exists') - - if (readtype) then - if (.not.exists) then - call shr_sys_abort(trim(subname)//' ERROR: '//trim(filename)//' doesnt exist') - endif - nmode = pio_nowrite - rcode = pio_openfile(iosystem, fid, pio_iotype, trim(filename), nmode) - else - if (.not.lclobber .and. exists) then - call shr_sys_abort(trim(subname)//' ERROR: '//trim(filename)//' exists, no clobber set') - endif - if (lclobber .or. .not.exists) then - nmode = pio_clobber - if(pio_iotype .eq. PIO_IOTYPE_NETCDF .or. & - pio_iotype .eq. PIO_IOTYPE_PNETCDF) then - nmode = ior(nmode,lio_format) - endif - rcode = pio_createfile(iosystem, fid, pio_iotype, trim(filename), nmode) - else - nmode = pio_write - rcode = pio_openfile(iosystem, fid, pio_iotype, trim(filename), nmode) - endif - rcode = pio_put_att(fid,pio_global,"file_version",version) - endif - call pio_seterrorhandling(fid,PIO_INTERNAL_ERROR) - - if (readtype) then - minloop = 11 - maxloop = 11 - else - minloop = 21 - maxloop = 22 - endif - - ! loop = 11 is read - ! loop = 21 is define - ! loop = 22 is write - do loop = minloop,maxloop - - if (loop == 21) rcode = pio_def_dim(fid,'gsize',gsize,dimid1(1)) - - if (present(id1)) then - fname = 'id1' - if (present(id1n)) fname = trim(id1n) - if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id1) - if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id1) - endif - - if (present(id2)) then - fname = 'id2' - if (present(id2n)) fname = trim(id2n) - if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id2) - if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id2) - endif - - if (present(id3)) then - fname = 'id3' - if (present(id3n)) fname = trim(id3n) - if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id3) - if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id3) - endif - - if (present(id4)) then - fname = 'id4' - if (present(id4n)) fname = trim(id4n) - if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id4) - if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id4) - endif - - if (present(rs1)) then - fname = 'rs1' - if (present(rs1n)) fname = trim(rs1n) - if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs1) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) - if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs1) - endif - - if (present(rs2)) then - fname = 'rs2' - if (present(rs2n)) fname = trim(rs2n) - if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs2) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) - if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs2) - endif - - if (present(rs3)) then - fname = 'rs3' - if (present(rs3n)) fname = trim(rs3n) - if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs3) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) - if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs3) - endif - - if (present(rs4)) then - fname = 'rs4' - if (present(rs4n)) fname = trim(rs4n) - if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs4) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) - if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs4) - endif - - if (present(is1)) then - fname = 'is1' - if (present(is1n)) fname = trim(is1n) - if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is1) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) - if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is1) - endif - - if (present(is2)) then - fname = 'is2' - if (present(is2n)) fname = trim(is2n) - if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is2) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) - if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is2) - endif - - if (present(is3)) then - fname = 'is3' - if (present(is3n)) fname = trim(is3n) - if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is3) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) - if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is3) - endif - - if (present(is4)) then - fname = 'is4' - if (present(is4n)) fname = trim(is4n) - if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is4) - if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) - if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is4) - endif - - if (present(rf1)) then - fname = 'rf1' - if (present(rf1n)) fname = trim(rf1n) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf1) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf1) - endif - - if (present(rf2)) then - fname = 'rf2' - if (present(rf2n)) fname = trim(rf2n) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf2) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf2) - endif - - if (present(rf3)) then - fname = 'rf3' - if (present(rf3n)) fname = trim(rf3n) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf3) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf3) - endif - - if (present(rf4)) then - fname = 'rf4' - if (present(rf4n)) fname = trim(rf4n) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf4) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf4) - endif - - if (present(if1)) then - fname = 'if1' - if (present(if1n)) fname = trim(if1n) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if1) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if1) - endif - - if (present(if2)) then - fname = 'if2' - if (present(if2n)) fname = trim(if2n) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if2) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if2) - endif - - if (present(if3)) then - fname = 'if3' - if (present(if3n)) fname = trim(if3n) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if3) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if3) - endif - - if (present(if4)) then - fname = 'if4' - if (present(if4n)) fname = trim(if4n) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if4) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if4) - endif - - if (present(av1)) then - fname = 'av1_' - if (present(av1n)) then - if (trim(av1n) == '') then - fname = trim(av1n) - else - fname = trim(av1n)//'_' - endif - endif - nf = mct_aVect_nRattr(av1) - do n = 1,nf - call mct_aVect_getRList(mstring,n,av1) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av1%rAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av1%rAttr(n,:)) - enddo - nf = mct_aVect_nIattr(av1) - do n = 1,nf - call mct_aVect_getIList(mstring,n,av1) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av1%iAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av1%iAttr(n,:)) - enddo - endif - - if (present(av2)) then - fname = 'av2_' - if (present(av2n)) then - if (trim(av2n) == '') then - fname = trim(av2n) - else - fname = trim(av2n)//'_' - endif - endif - nf = mct_aVect_nRattr(av2) - do n = 1,nf - call mct_aVect_getRList(mstring,n,av2) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av2%rAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av2%rAttr(n,:)) - enddo - nf = mct_aVect_nIattr(av2) - do n = 1,nf - call mct_aVect_getIList(mstring,n,av2) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av2%iAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av2%iAttr(n,:)) - enddo - endif - - if (present(av3)) then - fname = 'av3_' - if (present(av3n)) then - if (trim(av3n) == '') then - fname = trim(av3n) - else - fname = trim(av3n)//'_' - endif - endif - nf = mct_aVect_nRattr(av3) - do n = 1,nf - call mct_aVect_getRList(mstring,n,av3) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av3%rAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av3%rAttr(n,:)) - enddo - nf = mct_aVect_nIattr(av3) - do n = 1,nf - call mct_aVect_getIList(mstring,n,av3) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av3%iAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av3%iAttr(n,:)) - enddo - endif - - if (present(av4)) then - fname = 'av4_' - if (present(av4n)) then - if (trim(av4n) == '') then - fname = trim(av4n) - else - fname = trim(av4n)//'_' - endif - endif - nf = mct_aVect_nRattr(av4) - do n = 1,nf - call mct_aVect_getRList(mstring,n,av4) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av4%rAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) - if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av4%rAttr(n,:)) - enddo - nf = mct_aVect_nIattr(av4) - do n = 1,nf - call mct_aVect_getIList(mstring,n,av4) - vname = trim(fname)//trim(mct_string_toChar(mstring)) - call mct_string_clean(mstring) - if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av4%iAttr(n,:)) - if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) - if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av4%iAttr(n,:)) - enddo - endif - - if (loop == 21) rcode = pio_enddef(fid) - enddo - - call pio_freedecomp(fid,iodesci) - call pio_freedecomp(fid,iodescd) - call pio_closefile(fid) - -end subroutine shr_pcdf_readwrite - -!=============================================================================== -!=============================================================================== -subroutine shr_pcdf_defvar0d(fid,fname,vtype) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - integer(IN) ,intent(in) :: vtype - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_defvar0d) ' - - !------------- - - rcode = pio_def_var(fid,trim(fname),vtype,varid) - if (vtype == PIO_DOUBLE) then - rcode = PIO_put_att(fid, varid, '_FillValue', fillvalue) - else - rcode = PIO_put_att(fid, varid, '_FillValue', ifillvalue) - endif -end subroutine shr_pcdf_defvar0d - -!=============================================================================== -subroutine shr_pcdf_defvar1d(fid,fname,vtype,dimid) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - integer(IN) ,intent(in) :: vtype - integer(IN) ,intent(in) :: dimid(:) - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_defvar1d) ' - - !------------- - - rcode = pio_def_var(fid,trim(fname),vtype,dimid,varid) - if (vtype == PIO_DOUBLE) then - rcode = PIO_put_att(fid, varid, '_FillValue', fillvalue) - else - rcode = PIO_put_att(fid, varid, '_FillValue', ifillvalue) - endif - -end subroutine shr_pcdf_defvar1d - -!=============================================================================== -subroutine shr_pcdf_readr1d(fid,fname,iodesc,r1d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - type(io_desc_t) ,intent(inout) :: iodesc - real(R8) ,intent(inout) :: r1d(:) - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_readr1d) ' - - !------------- - - rcode = pio_inq_varid(fid,trim(fname),varid) - - call pio_read_darray(fid,varid,iodesc,r1d,rcode) - -end subroutine shr_pcdf_readr1d - -!=============================================================================== -subroutine shr_pcdf_writer1d(fid,fname,iodesc,r1d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - type(io_desc_t) ,intent(inout) :: iodesc - real(R8) ,intent(inout) :: r1d(:) - - !--- local --- - type(var_desc_t) :: varid - real(R8) :: lfillvalue - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_writer1d) ' - - !------------- - - lfillvalue = fillvalue - - rcode = pio_inq_varid(fid,trim(fname),varid) - - call pio_write_darray(fid, varid, iodesc, r1d, rcode, fillval=lfillvalue) - -end subroutine shr_pcdf_writer1d -!=============================================================================== -!=============================================================================== -subroutine shr_pcdf_readi1d(fid,fname,iodesc,i1d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - type(io_desc_t) ,intent(inout) :: iodesc - integer(IN) ,intent(inout) :: i1d(:) - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_readi1d) ' - - !------------- - - rcode = pio_inq_varid(fid,trim(fname),varid) - - call pio_read_darray(fid,varid,iodesc,i1d,rcode) - -end subroutine shr_pcdf_readi1d - -!=============================================================================== -subroutine shr_pcdf_writei1d(fid,fname,iodesc,i1d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - type(io_desc_t) ,intent(inout) :: iodesc - integer(IN) ,intent(inout) :: i1d(:) - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: lfillvalue - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_writei1d) ' - - !------------- - - lfillvalue = ifillvalue - - rcode = pio_inq_varid(fid,trim(fname),varid) - call pio_write_darray(fid, varid, iodesc, i1d, rcode, fillval=lfillvalue) - -end subroutine shr_pcdf_writei1d -!=============================================================================== -!=============================================================================== -subroutine shr_pcdf_readr0d(fid,fname,r0d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - real(R8) ,intent(inout) :: r0d - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_readr0d) ' - - !------------- - - rcode = pio_inq_varid(fid,trim(fname),varid) - rcode = pio_get_var(fid,varid,r0d) - -end subroutine shr_pcdf_readr0d - -!=============================================================================== -subroutine shr_pcdf_writer0d(fid,fname,r0d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - real(R8) ,intent(inout) :: r0d - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_writer0d) ' - - !------------- - - rcode = pio_inq_varid(fid,trim(fname),varid) - rcode = pio_put_var(fid, varid, r0d) - -end subroutine shr_pcdf_writer0d -!=============================================================================== -!=============================================================================== -subroutine shr_pcdf_readi0d(fid,fname,i0d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - integer(IN) ,intent(inout) :: i0d - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_readi0d) ' - - !------------- - - rcode = pio_inq_varid(fid,trim(fname),varid) - rcode = pio_get_var(fid,varid,i0d) - -end subroutine shr_pcdf_readi0d - -!=============================================================================== -subroutine shr_pcdf_writei0d(fid,fname,i0d) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - integer(IN) ,intent(inout) :: i0d - - !--- local --- - type(var_desc_t) :: varid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_writei0d) ' - - !------------- - - rcode = pio_inq_varid(fid,trim(fname),varid) - rcode = pio_put_var(fid, varid, i0d) - -end subroutine shr_pcdf_writei0d -!=============================================================================== -!=============================================================================== -subroutine shr_pcdf_readdim(fid,fname,dim) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - integer(IN) ,intent(inout) :: dim - - !--- local --- - integer(IN) :: dimid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_readdim) ' - - !------------- - - rcode = pio_inq_dimid(fid,trim(fname),dimid) - rcode = pio_inq_dimlen(fid,dimid,dim) - -end subroutine shr_pcdf_readdim - -!=============================================================================== -subroutine shr_pcdf_writedim(fid,fname,dim) - - implicit none - - type(file_desc_t),intent(inout) :: fid - character(len=*) ,intent(in) :: fname - integer(IN) ,intent(inout) :: dim - - !--- local --- - integer(IN) :: dimid - integer(IN) :: rcode - character(len=*),parameter :: subname = '(shr_pcdf_writedim) ' - - !------------- - - rcode = pio_def_dim(fid,trim(fname),dim,dimid) - -end subroutine shr_pcdf_writedim -!=============================================================================== -!=============================================================================== -!=============================================================================== - -end module shr_pcdf_mod diff --git a/src/shr_reprosum_mod.F90 b/src/shr_reprosum_mod.F90 index 9d10b9e..fb61f42 100644 --- a/src/shr_reprosum_mod.F90 +++ b/src/shr_reprosum_mod.F90 @@ -43,8 +43,9 @@ module shr_reprosum_mod shr_infnan_nan, & shr_infnan_isnan, shr_infnan_isinf, & shr_infnan_isposinf, shr_infnan_isneginf +#ifdef TIMING use perf_mod - +#endif !----------------------------------------------------------------------- !- module boilerplate -------------------------------------------------- !----------------------------------------------------------------------- @@ -456,9 +457,9 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & if ( present(allow_infnan) ) then abort_inf_nan = .not. allow_infnan endif - +#ifdef TIMING call t_startf('shr_reprosum_INF_NaN_Chk') - +#endif ! initialize flags to indicate that no NaNs or INFs are present in the input data inf_nan_gchecks = .false. arr_gsum_infnan = .false. @@ -495,21 +496,23 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & inf_nan_lchecks(2,ifld) = any(shr_infnan_isposinf(arr(:,ifld))) inf_nan_lchecks(3,ifld) = any(shr_infnan_isneginf(arr(:,ifld))) end do - +#ifdef TIMING call t_startf("repro_sum_allr_lor") +#endif call mpi_allreduce (inf_nan_lchecks, inf_nan_gchecks, 3*nflds, & MPI_LOGICAL, MPI_LOR, mpi_comm, ierr) gbl_lor_red = 1 +#ifdef TIMING call t_stopf("repro_sum_allr_lor") - +#endif do ifld=1,nflds arr_gsum_infnan(ifld) = any(inf_nan_gchecks(:,ifld)) enddo endif - +#ifdef TIMING call t_stopf('shr_reprosum_INF_NaN_Chk') - +#endif ! check whether should use shr_reprosum_ddpdd algorithm use_ddpdd_sum = repro_sum_use_ddpdd if ( present(ddpdd_sum) ) then @@ -522,19 +525,19 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & use_ddpdd_sum = use_ddpdd_sum .or. (radix(0._r8) /= radix(0_i8)) if ( use_ddpdd_sum ) then - +#ifdef TIMING call t_startf('shr_reprosum_ddpdd') - +#endif call shr_reprosum_ddpdd(arr, arr_gsum, nsummands, dsummands, & nflds, mpi_comm) repro_sum_fast = 1 - +#ifdef TIMING call t_stopf('shr_reprosum_ddpdd') - +#endif else - +#ifdef TIMING call t_startf('shr_reprosum_int') - +#endif ! get number of MPI tasks call mpi_comm_size(mpi_comm, tasks, ierr) @@ -571,7 +574,9 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & ! determine maximum number of summands in local phases of the ! algorithm +#ifdef TIMING call t_startf("repro_sum_allr_max") +#endif if ( present(gbl_max_nsummands) ) then if (gbl_max_nsummands < 1) then call mpi_allreduce (nsummands, max_nsummands, 1, & @@ -585,8 +590,9 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & MPI_INTEGER, MPI_MAX, mpi_comm, ierr) gbl_max_red = 1 endif +#ifdef TIMING call t_stopf("repro_sum_allr_max") - +#endif ! determine maximum shift. Shift needs to be small enough that summation ! does not exceed maximum number of digits in i8. @@ -668,7 +674,9 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & !$omp default(shared) & !$omp private(ithread, ifld, isum, arr_exp, arr_exp_tlmin, arr_exp_tlmax) do ithread=1,omp_nthreads +#ifdef TIMING call t_startf('repro_sum_loopa') +#endif do ifld=1,nflds arr_exp_tlmin = MAXEXPONENT(1._r8) arr_exp_tlmax = MINEXPONENT(1._r8) @@ -684,7 +692,9 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & arr_tlmin_exp(ifld,ithread) = arr_exp_tlmin arr_tlmax_exp(ifld,ithread) = arr_exp_tlmax end do +#ifdef TIMING call t_stopf('repro_sum_loopa') +#endif end do do ifld=1,nflds @@ -696,10 +706,14 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & arr_lextremes(0,:) = -nsummands arr_lextremes(1:nflds,1) = -arr_lmax_exp(:) arr_lextremes(1:nflds,2) = arr_lmin_exp(:) +#ifdef TIMING call t_startf("repro_sum_allr_minmax") +#endif call mpi_allreduce (arr_lextremes, arr_gextremes, 2*(nflds+1), & MPI_INTEGER, MPI_MIN, mpi_comm, ierr) +#ifdef TIMING call t_stopf("repro_sum_allr_minmax") +#endif max_nsummands = -arr_gextremes(0,1) arr_gmax_exp(:) = -arr_gextremes(1:nflds,1) arr_gmin_exp(:) = arr_gextremes(1:nflds,2) @@ -784,17 +798,18 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & validate, recompute, omp_nthreads, mpi_comm) endif - +#ifdef TIMING call t_stopf('shr_reprosum_int') - +#endif endif ! compare fixed and floating point results if ( present(rel_diff) ) then if (shr_reprosum_reldiffmax >= 0.0_r8) then - +#ifdef TIMING call t_barrierf('sync_nonrepro_sum',mpi_comm) call t_startf('nonrepro_sum') +#endif ! record statistic nonrepro_sum = 1 ! compute nonreproducible sum @@ -809,14 +824,16 @@ subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & end do endif end do - +#ifdef TIMING call t_startf("nonrepro_sum_allr_r8") +#endif call mpi_allreduce (arr_lsum, arr_gsum_fast, nflds, & MPI_REAL8, MPI_SUM, mpi_comm, ierr) +#ifdef TIMING call t_stopf("nonrepro_sum_allr_r8") call t_stopf('nonrepro_sum') - +#endif ! determine differences !$omp parallel do & !$omp default(shared) & @@ -1026,8 +1043,10 @@ subroutine shr_reprosum_int (arr, arr_gsum, nsummands, dsummands, nflds, & !$omp private(ithread, ifld, ioffset, isum, arr_frac, arr_exp, & !$omp arr_shift, ilevel, i8_arr_level, arr_remainder, RX_8, IX_8) do ithread=1,omp_nthreads - call t_startf('repro_sum_loopb') - do ifld=1,nflds +#ifdef TIMING + call t_startf('repro_sum_loopb') +#endif + do ifld=1,nflds ioffset = offset(ifld) max_error(ifld,ithread) = 0 @@ -1115,7 +1134,9 @@ subroutine shr_reprosum_int (arr, arr_gsum, nsummands, dsummands, nflds, & endif enddo enddo +#ifdef TIMING call t_stopf('repro_sum_loopb') +#endif enddo ! sum contributions from different threads @@ -1143,16 +1164,24 @@ subroutine shr_reprosum_int (arr, arr_gsum, nsummands, dsummands, nflds, & ! sum integer vector element-wise #if ( defined noI8 ) ! Workaround for when shr_kind_i8 is not supported. +#ifdef TIMING call t_startf("repro_sum_allr_i4") +#endif call mpi_allreduce (i8_arr_lsum_level, i8_arr_gsum_level, & veclth, MPI_INTEGER, MPI_SUM, mpi_comm, ierr) +#ifdef TIMING call t_stopf("repro_sum_allr_i4") +#endif #else +#ifdef TIMING call t_startf("repro_sum_allr_i8") +#endif call mpi_allreduce (i8_arr_lsum_level, i8_arr_gsum_level, & veclth, MPI_INTEGER8, MPI_SUM, mpi_comm, ierr) +#ifdef TIMING call t_stopf("repro_sum_allr_i8") #endif +#endif ! Construct global sum from integer vector representation: ! 1) arr_max_shift is the shift applied to fraction(arr_gmax) . @@ -1483,12 +1512,14 @@ subroutine shr_reprosum_ddpdd (arr, arr_gsum, nsummands, dsummands, & enddo enddo - +#ifdef TIMING call t_startf("repro_sum_allr_c16") +#endif call mpi_allreduce (arr_lsum_dd, arr_gsum_dd, nflds, & MPI_COMPLEX16, mpi_sumdd, mpi_comm, ierr) +#ifdef TIMING call t_stopf("repro_sum_allr_c16") - +#endif do ifld=1,nflds arr_gsum(ifld) = real(arr_gsum_dd(ifld)) enddo From e3838b53726756852106dfedcc0c344c56b845dc Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 10:58:59 -0600 Subject: [PATCH 02/26] remove old code, add extbuild github workflow --- .github/actions/buildshare/action.yaml | 46 + .github/workflows/extbuild.yml | 76 + CMakeLists.txt | 2 +- src/esmf_wrf_timemgr/CMakeLists.txt | 19 - src/esmf_wrf_timemgr/ESMF.F90 | 19 - src/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 | 102 - src/esmf_wrf_timemgr/ESMF_AlarmMod.F90 | 1040 ---------- src/esmf_wrf_timemgr/ESMF_BaseMod.F90 | 1089 ----------- src/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 | 459 ----- src/esmf_wrf_timemgr/ESMF_CalendarMod.F90 | 502 ----- src/esmf_wrf_timemgr/ESMF_ClockMod.F90 | 1247 ------------ src/esmf_wrf_timemgr/ESMF_FractionMod.F90 | 83 - src/esmf_wrf_timemgr/ESMF_Macros.inc | 36 - src/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 | 45 - src/esmf_wrf_timemgr/ESMF_Stubs.F90 | 167 -- src/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 | 1739 ----------------- src/esmf_wrf_timemgr/ESMF_TimeMgr.inc | 45 - src/esmf_wrf_timemgr/ESMF_TimeMod.F90 | 1572 --------------- src/esmf_wrf_timemgr/Makefile | 60 - src/esmf_wrf_timemgr/MeatMod.F90 | 65 - src/esmf_wrf_timemgr/README | 19 - src/esmf_wrf_timemgr/unittests/Makefile | 63 - src/esmf_wrf_timemgr/unittests/go.csh | 14 - src/esmf_wrf_timemgr/unittests/test.F90 | 312 --- src/esmf_wrf_timemgr/unittests/wrf_stuff.F90 | 17 - src/esmf_wrf_timemgr/wrf_error_fatal.F90 | 9 - src/esmf_wrf_timemgr/wrf_message.F90 | 5 - test/old_unit_testers/Makefile | 163 -- test/old_unit_testers/Mkdepends | 327 ---- test/old_unit_testers/Mksrcfiles | 60 - test/old_unit_testers/bundle_expected.F90 | 212 -- test/old_unit_testers/config.h | 7 - test/old_unit_testers/make.Macros | 369 ---- test/old_unit_testers/namelist | 10 - test/old_unit_testers/nl/atm.stdin | 2 - test/old_unit_testers/nl/cpl.stdin | 2 - test/old_unit_testers/nl/ice.stdin | 2 - test/old_unit_testers/nl/lnd.stdin | 2 - test/old_unit_testers/nl/ocn.stdin | 2 - test/old_unit_testers/run_dshr_bundle_test | 96 - test/old_unit_testers/run_file_test | 68 - test/old_unit_testers/test_mod.F90 | 339 ---- test/old_unit_testers/test_shr_file.F90 | 220 --- test/old_unit_testers/test_shr_log.F90 | 28 - test/old_unit_testers/test_shr_mpi.F90 | 291 --- test/old_unit_testers/test_shr_orb.F90 | 47 - test/old_unit_testers/test_shr_scam.F90 | 156 -- test/old_unit_testers/test_shr_streams.F90 | 663 ------- test/old_unit_testers/test_shr_sys.F90 | 75 - test/old_unit_testers/test_shr_tInterp.F90 | 108 - 50 files changed, 123 insertions(+), 11978 deletions(-) create mode 100644 .github/actions/buildshare/action.yaml create mode 100644 .github/workflows/extbuild.yml delete mode 100644 src/esmf_wrf_timemgr/CMakeLists.txt delete mode 100644 src/esmf_wrf_timemgr/ESMF.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_AlarmMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_BaseMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_CalendarMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_ClockMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_FractionMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_Macros.inc delete mode 100644 src/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_Stubs.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 delete mode 100644 src/esmf_wrf_timemgr/ESMF_TimeMgr.inc delete mode 100644 src/esmf_wrf_timemgr/ESMF_TimeMod.F90 delete mode 100644 src/esmf_wrf_timemgr/Makefile delete mode 100644 src/esmf_wrf_timemgr/MeatMod.F90 delete mode 100644 src/esmf_wrf_timemgr/README delete mode 100644 src/esmf_wrf_timemgr/unittests/Makefile delete mode 100755 src/esmf_wrf_timemgr/unittests/go.csh delete mode 100644 src/esmf_wrf_timemgr/unittests/test.F90 delete mode 100644 src/esmf_wrf_timemgr/unittests/wrf_stuff.F90 delete mode 100644 src/esmf_wrf_timemgr/wrf_error_fatal.F90 delete mode 100644 src/esmf_wrf_timemgr/wrf_message.F90 delete mode 100644 test/old_unit_testers/Makefile delete mode 100755 test/old_unit_testers/Mkdepends delete mode 100755 test/old_unit_testers/Mksrcfiles delete mode 100644 test/old_unit_testers/bundle_expected.F90 delete mode 100644 test/old_unit_testers/config.h delete mode 100644 test/old_unit_testers/make.Macros delete mode 100644 test/old_unit_testers/namelist delete mode 100644 test/old_unit_testers/nl/atm.stdin delete mode 100644 test/old_unit_testers/nl/cpl.stdin delete mode 100644 test/old_unit_testers/nl/ice.stdin delete mode 100644 test/old_unit_testers/nl/lnd.stdin delete mode 100644 test/old_unit_testers/nl/ocn.stdin delete mode 100755 test/old_unit_testers/run_dshr_bundle_test delete mode 100755 test/old_unit_testers/run_file_test delete mode 100644 test/old_unit_testers/test_mod.F90 delete mode 100644 test/old_unit_testers/test_shr_file.F90 delete mode 100644 test/old_unit_testers/test_shr_log.F90 delete mode 100644 test/old_unit_testers/test_shr_mpi.F90 delete mode 100644 test/old_unit_testers/test_shr_orb.F90 delete mode 100644 test/old_unit_testers/test_shr_scam.F90 delete mode 100644 test/old_unit_testers/test_shr_streams.F90 delete mode 100644 test/old_unit_testers/test_shr_sys.F90 delete mode 100644 test/old_unit_testers/test_shr_tInterp.F90 diff --git a/.github/actions/buildshare/action.yaml b/.github/actions/buildshare/action.yaml new file mode 100644 index 0000000..913e952 --- /dev/null +++ b/.github/actions/buildshare/action.yaml @@ -0,0 +1,46 @@ +name: SHARE build and cache +description: 'Build the SHARE library' +inputs: + share_version: + description: 'Tag in the SHARE repository to use' + default: main + required: False + type: string + pio_path: + description: 'Path to the installed parallelio code root' + default: $HOME/pio + required: False + type: string + esmfmkfile: + description: 'Path to the installed ESMF library mkfile' + default: $HOME/ESMF/lib/libg/Linux.gfortran.64.openmpi.default/esmf.mk + required: False + type: string + src_root: + description: 'Path to share source' + default: $GITHUB_WORKSPACE + required: False + type: string + cmake_flags: + description: 'Extra flags for cmake command' + default: -Wno-dev + required: False + type: string + install_prefix: + description: 'Install path of share' + default: $HOME/share + required: False + type: string +runs: + using: composite + steps: + - id : Build-SHARE + shell: bash + run: | + mkdir build-share + pushd build-share + export ESMFMKFILE=${{ inputs.esmfmkfile }} + export PIO=${{ inputs.pio_path }} + cmake ${{ inputs.cmake_flags }} ${{ inputs.src_root }} + make VERBOSE=1 + popd diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml new file mode 100644 index 0000000..ecb32eb --- /dev/null +++ b/.github/workflows/extbuild.yml @@ -0,0 +1,76 @@ +# This is a workflow to compile the share source without cime +name: extbuild +# Controls when the action will run. Triggers the workflow on push or pull request +# events but only for the main branch +on: + push: + branches: [ main ] + pull_request: + branches: [ main ] + +# A workflow run is made up of one or more jobs that can run sequentially or in parallel +jobs: + build-share: + runs-on: ubuntu-latest + env: + CC: mpicc + FC: mpifort + CXX: mpicxx + CPPFLAGS: "-I/usr/include -I/usr/local/include " + LDFLAGS: "-L/usr/lib/x86_64-linux-gnu " + # Versions of all dependencies can be updated here - these match tag names in the github repo + ESMF_VERSION: v8.6.1 + ParallelIO_VERSION: pio2_6_2 + steps: + - id: checkout-share + uses: actions/checkout@v4 + - id: load-env + run: | + sudo apt-get update + sudo apt-get install gfortran + sudo apt-get install wget + sudo apt-get install openmpi-bin libopenmpi-dev + sudo apt-get install netcdf-bin libnetcdf-dev libnetcdff-dev + sudo apt-get install pnetcdf-bin libpnetcdf-dev + - name: Cache PARALLELIO + id: cache-PARALLELIO + uses: actions/cache@v4 + with: + path: ${GITHUB_WORKSPACE}/pio + key: ${{ runner.os }}-${{ env.ParallelIO_VERSION }}-parallelio2 + - name: Build ParallelIO + if: steps.cache-PARALLELIO.outputs.cache-hit != 'true' + uses: NCAR/ParallelIO/.github/actions/parallelio_cmake@9390e30e29d4ebbfbef0fc72162cacd9e8f25e4e + with: + parallelio_version: ${{ env.ParallelIO_VERSION }} + enable_fortran: True + install_prefix: ${GITHUB_WORKSPACE}/pio + - name: Install ESMF + uses: esmf-org/install-esmf-action@v1 + env: + ESMF_COMPILER: gfortran + ESMF_BOPT: g + ESMF_COMM: openmpi + ESMF_NETCDF: nc-config + ESMF_PNETCDF: pnetcdf-config + ESMF_INSTALL_PREFIX: ${GITHUB_WORKSPACE}/ESMF + ESMF_PIO: external + ESMF_PIO_INCLUDE: ${GITHUB_WORKSPACE}/pio/include + ESMF_PIO_LIBPATH: ${GITHUB_WORKSPACE}/pio/lib + with: + version: ${{ env.ESMF_VERSION }} + esmpy: false + cache: true + + - name: Build SHARE + uses: ./.github/actions/buildshare + with: + esmfmkfile: $ESMFMKFILE + pio_path: ${GITHUB_WORKSPACE}/pio + src_root: ${GITHUB_WORKSPACE} + cmake_flags: " -Wno-dev -DCMAKE_BUILD_TYPE=DEBUG -DWERROR=ON -DCMAKE_Fortran_FLAGS=\"-DCPRGNU -g -Wall \ + -ffree-form -ffree-line-length-none -fallow-argument-mismatch \"" + - name: Test CDEPS + run: | + cd build-share + make VERBOSE=1 diff --git a/CMakeLists.txt b/CMakeLists.txt index af2dfbd..edd3ef1 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -54,7 +54,7 @@ set(ENABLE_GENF90 ON) set(GENF90 "${GENF90_PATH}/genf90.pl") include(${GENF90_PATH}/CMake/genf90_utils.cmake) process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) -file(GLOB SOURCES "src/*.c" "src/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") +file(GLOB SOURCES "src/*.c" "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") list(APPEND SOURCES "${SHAREGENF90SRC}") add_definitions(-DCPRINTEL) diff --git a/src/esmf_wrf_timemgr/CMakeLists.txt b/src/esmf_wrf_timemgr/CMakeLists.txt deleted file mode 100644 index d274805..0000000 --- a/src/esmf_wrf_timemgr/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -list(APPEND esmf_wrf_timemgr_sources - ESMF.F90 - ESMF_AlarmClockMod.F90 - ESMF_AlarmMod.F90 - ESMF_BaseMod.F90 - ESMF_BaseTimeMod.F90 - ESMF_CalendarMod.F90 - ESMF_ClockMod.F90 - ESMF_FractionMod.F90 - ESMF_ShrTimeMod.F90 - ESMF_Stubs.F90 - ESMF_TimeIntervalMod.F90 - ESMF_TimeMod.F90 - MeatMod.F90 - wrf_error_fatal.F90 - wrf_message.F90 - ) - -sourcelist_to_parent(esmf_wrf_timemgr_sources) \ No newline at end of file diff --git a/src/esmf_wrf_timemgr/ESMF.F90 b/src/esmf_wrf_timemgr/ESMF.F90 deleted file mode 100644 index 11f79a6..0000000 --- a/src/esmf_wrf_timemgr/ESMF.F90 +++ /dev/null @@ -1,19 +0,0 @@ -! TBH: This version is for use with the ESMF library embedded in the WRF -! TBH: distribution. -MODULE ESMF - USE ESMF_AlarmMod - USE ESMF_BaseMod - USE ESMF_BaseTimeMod - USE ESMF_CalendarMod - USE ESMF_ClockMod - USE ESMF_FractionMod - USE ESMF_TimeIntervalMod - USE ESMF_TimeMod - USE ESMF_ShrTimeMod - USE ESMF_AlarmClockMod - USE ESMF_Stubs ! add new dummy interfaces and typedefs here as needed - USE MeatMod -#include - INTEGER, PARAMETER :: ESMF_MAX_ALARMS=MAX_ALARMS -! -END MODULE ESMF diff --git a/src/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 b/src/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 deleted file mode 100644 index c9bebb2..0000000 --- a/src/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 +++ /dev/null @@ -1,102 +0,0 @@ -! $Id$ -! -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF Alarm-Clock Module - module ESMF_AlarmClockMod -! -!============================================================================== -! -! This file contains the AlarmCreae method. -! -!------------------------------------------------------------------------------ -! INCLUDES -#include - -!=============================================================================== -!BOPI -! -! !MODULE: ESMF_AlarmClockMod -! -! !DESCRIPTION: -! Separate module that uses both ESMF_AlarmMod and ESMF_ClockMod. -! Separation is needed to avoid cyclic dependence. -! -! Defines F90 wrapper entry points for corresponding -! C++ class {\tt ESMC\_Alarm} -! -! See {\tt ../include/ESMC\_Alarm.h} for complete description -! -!------------------------------------------------------------------------------ -! !USES: - ! inherit ESMF_Alarm and ESMF_Clock - use ESMF_AlarmMod, only : ESMF_Alarm, ESMF_AlarmSet - use ESMF_ClockMod, only : ESMF_Clock, ESMF_ClockAddAlarm - - ! associated derived types - use ESMF_TimeIntervalMod, only : ESMF_TimeInterval - use ESMF_TimeMod, only : ESMF_Time - - implicit none - -!------------------------------------------------------------------------------ -! !PRIVATE TYPES: - private -!------------------------------------------------------------------------------ - -! !PUBLIC MEMBER FUNCTIONS: - public ESMF_AlarmCreate - -!------------------------------------------------------------------------------ -! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - -!============================================================================== - - contains - -!============================================================================== - - -! Create ESMF_Alarm using ESMF 2.1.0+ semantics - FUNCTION ESMF_AlarmCreate( name, clock, RingTime, RingInterval, & - StopTime, Enabled, rc ) - - ! return value - type(ESMF_Alarm) :: ESMF_AlarmCreate - ! !ARGUMENTS: - character(len=*), intent(in) :: name - type(ESMF_Clock), intent(inout) :: clock - type(ESMF_Time), intent(in), optional :: RingTime - type(ESMF_TimeInterval), intent(in), optional :: RingInterval - type(ESMF_Time), intent(in), optional :: StopTime - logical, intent(in), optional :: Enabled - integer, intent(out), optional :: rc - ! locals - type(ESMF_Alarm) :: alarmtmp - ! TBH: ignore allocate errors, for now - ALLOCATE( alarmtmp%alarmint ) - CALL ESMF_AlarmSet( alarmtmp, & - name=name, & - RingTime=RingTime, & - RingInterval=RingInterval, & - StopTime=StopTime, & - Enabled=Enabled, & - rc=rc ) - CALL ESMF_ClockAddAlarm( clock, alarmtmp, rc ) - ESMF_AlarmCreate = alarmtmp - END FUNCTION ESMF_AlarmCreate - - -!------------------------------------------------------------------------------ - - end module ESMF_AlarmClockMod diff --git a/src/esmf_wrf_timemgr/ESMF_AlarmMod.F90 b/src/esmf_wrf_timemgr/ESMF_AlarmMod.F90 deleted file mode 100644 index 8c78ef5..0000000 --- a/src/esmf_wrf_timemgr/ESMF_AlarmMod.F90 +++ /dev/null @@ -1,1040 +0,0 @@ -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF Alarm Module -module ESMF_AlarmMod - ! - !============================================================================== - ! - ! This file contains the Alarm class definition and all Alarm class - ! methods. - ! - !------------------------------------------------------------------------------ - ! INCLUDES -#include - - !=============================================================================== - !BOPI - ! - ! !MODULE: ESMF_AlarmMod - ! - ! !DESCRIPTION: - ! Part of Time Manager F90 API wrapper of C++ implemenation - ! - ! Defines F90 wrapper entry points for corresponding - ! C++ class {\tt ESMC\_Alarm} - ! - ! See {\tt ../include/ESMC\_Alarm.h} for complete description - ! - !------------------------------------------------------------------------------ - ! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! associated derived types - use ESMF_TimeIntervalMod - use ESMF_TimeMod - - implicit none - - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_Alarm - ! - ! ! F90 class type to match C++ Alarm class in size only; - ! ! all dereferencing within class is performed by C++ implementation - - ! internals for ESMF_Alarm - type ESMF_AlarmInt - character(len=256) :: name = " " - type(ESMF_TimeInterval) :: RingInterval - type(ESMF_Time) :: RingTime - type(ESMF_Time) :: PrevRingTime - type(ESMF_Time) :: StopTime - integer :: ID - integer :: AlarmMutex - logical :: Ringing - logical :: Enabled - logical :: RingTimeSet - logical :: RingIntervalSet - logical :: StopTimeSet - end type ESMF_AlarmInt - - ! Actual public type: this bit allows easy mimic of "deep" ESMF_AlarmCreate - ! in ESMF 2.1.0+. Note that ESMF_AlarmCreate is in a separate module to avoid - ! cyclic dependence. - ! NOTE: DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE. It emulates ESMF - ! shallow-copy-masquerading-as-reference-copy insanity. - type ESMF_Alarm - type(ESMF_AlarmInt), pointer :: alarmint => null() - end type ESMF_Alarm - - !------------------------------------------------------------------------------ - ! !PUBLIC TYPES: - public ESMF_Alarm - public ESMF_AlarmInt ! needed on AIX but not PGI - !------------------------------------------------------------------------------ - - ! !PUBLIC MEMBER FUNCTIONS: - public ESMF_AlarmDestroy - public ESMF_AlarmSet - public ESMF_AlarmGet - ! public ESMF_AlarmGetRingInterval - ! public ESMF_AlarmSetRingInterval - ! public ESMF_AlarmGetRingTime - ! public ESMF_AlarmSetRingTime - ! public ESMF_AlarmGetPrevRingTime - ! public ESMF_AlarmSetPrevRingTime - ! public ESMF_AlarmGetStopTime - ! public ESMF_AlarmSetStopTime - public ESMF_AlarmEnable - public ESMF_AlarmDisable - public ESMF_AlarmRingerOn - public ESMF_AlarmRingerOff - public ESMF_AlarmIsRinging - ! public ESMF_AlarmCheckRingTime - public operator(==) - - ! Required inherited and overridden ESMF_Base class methods - - ! public ESMF_AlarmRead - ! public ESMF_AlarmWrite - public ESMF_AlarmValidate - public ESMF_AlarmPrint - - ! !PRIVATE MEMBER FUNCTIONS: - private ESMF_AlarmEQ - !EOPI - - !------------------------------------------------------------------------------ - ! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - - !============================================================================== - ! - ! INTERFACE BLOCKS - ! - !============================================================================== - !BOP - ! !INTERFACE: - interface operator(==) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_AlarmEQ - - ! !DESCRIPTION: - ! This interface overloads the == operator for the {\tt ESMF\_Alarm} class - ! - !EOP - end interface operator(==) - ! - !------------------------------------------------------------------------------ - - !============================================================================== - -contains - - !============================================================================== - - !------------------------------------------------------------------------------ - ! - ! This section includes the Set methods. - ! - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmSet - Initializes an alarm - - ! !INTERFACE: - subroutine ESMF_AlarmSet(alarm, name, RingTime, RingInterval, & - StopTime, Enabled, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm - character(len=*), intent(in), optional :: name - type(ESMF_Time), intent(in), optional :: RingTime - type(ESMF_TimeInterval), intent(in), optional :: RingInterval - type(ESMF_Time), intent(in), optional :: StopTime - logical, intent(in), optional :: Enabled - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Initializes an {\tt ESMF\_Alarm} - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to initialize - ! \item[{[RingTime]}] - ! Optional ring time for one-shot or first repeating alarm - ! \item[{[RingInterval]}] - ! Optional ring interval for repeating alarms - ! \item[{[StopTime]}] - ! Optional stop time for repeating alarms - ! \item[Enabled] - ! Alarm enabled/disabled - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.1, TMG4.7 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - alarm%alarmint%RingTimeSet = .FALSE. - alarm%alarmint%RingIntervalSet = .FALSE. - alarm%alarmint%StopTimeSet = .FALSE. - IF ( PRESENT( name ) ) THEN - alarm%alarmint%name = name - END IF - IF ( PRESENT( RingInterval ) ) THEN - alarm%alarmint%RingInterval = RingInterval - alarm%alarmint%RingIntervalSet = .TRUE. - ENDIF - IF ( PRESENT( RingTime ) ) THEN - alarm%alarmint%RingTime = RingTime - alarm%alarmint%RingTimeSet = .TRUE. - ENDIF - IF ( PRESENT( StopTime ) ) THEN - alarm%alarmint%StopTime = StopTime - alarm%alarmint%StopTimeSet = .TRUE. - ENDIF - alarm%alarmint%Enabled = .TRUE. - IF ( PRESENT( Enabled ) ) THEN - alarm%alarmint%Enabled = Enabled - ENDIF - IF ( PRESENT( rc ) ) THEN - rc = ESMF_SUCCESS - ENDIF - alarm%alarmint%Ringing = .FALSE. - alarm%alarmint%Enabled = .TRUE. - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - - end subroutine ESMF_AlarmSet - - - - ! Deallocate memory for ESMF_Alarm - SUBROUTINE ESMF_AlarmDestroy( alarm, rc ) - TYPE(ESMF_Alarm), INTENT(INOUT) :: alarm - INTEGER, INTENT( OUT), OPTIONAL :: rc - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - DEALLOCATE( alarm%alarmint ) - ENDIF - ! TBH: ignore deallocate errors, for now - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - END SUBROUTINE ESMF_AlarmDestroy - - - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmGetRingInterval - Get an alarm's ring interval - ! - ! !INTERFACE: - subroutine ESMF_AlarmGetRingInterval(alarm, RingInterval, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - type(ESMF_TimeInterval), intent(out) :: RingInterval - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Alarm}'s ring interval - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to get the ring interval - ! \item[RingInterval] - ! The {\tt Alarm}'s ring interval - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG4.7 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - IF ( alarm%alarmint%RingIntervalSet )THEN - RingInterval= alarm%alarmint%RingInterval - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - END IF - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end subroutine ESMF_AlarmGetRingInterval - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmSetRingInterval - Set an alarm's ring interval - ! - ! !INTERFACE: - subroutine ESMF_AlarmSetRingInterval(alarm, RingInterval, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(out) :: alarm - type(ESMF_TimeInterval), intent(in) :: RingInterval - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Alarm}'s ring interval - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to set the ring interval - ! \item[RingInterval] - ! The {\tt Alarm}'s ring interval - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.5.2, TMG4.7 - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmSetRingInterval not supported' ) - end subroutine ESMF_AlarmSetRingInterval - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmGetRingTime - Get an alarm's time to ring - ! - ! !INTERFACE: - subroutine ESMF_AlarmGetRingTime(alarm, RingTime, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - type(ESMF_Time), intent(out) :: RingTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Alarm}'s time to ring - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to get the ring time - ! \item[RingTime] - ! The {\tt ESMF\_Alarm}'s ring time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.7, TMG4.8 - !EOP - type(ESMF_Time) :: PrevRingTime - type(ESMF_TimeInterval) :: RingInterval - integer :: ierr - - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - IF ( alarm%alarmint%RingIntervalSet )THEN - PrevRingTime = alarm%alarmint%PrevRingTime - call ESMF_AlarmGetRingInterval( alarm, RingInterval, ierr) - IF ( PRESENT( rc ) .AND. (ierr /= ESMF_SUCCESS) )THEN - rc = ierr - return - END IF - RingTime = PrevRingTime + RingInterval - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE IF ( alarm%alarmint%RingTimeSet )THEN - RingTime = alarm%alarmint%RingTime - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - END IF - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end subroutine ESMF_AlarmGetRingTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmSetRingTime - Set an alarm's time to ring - ! - ! !INTERFACE: - subroutine ESMF_AlarmSetRingTime(alarm, RingTime, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(out) :: alarm - type(ESMF_Time), intent(in) :: RingTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Alarm}'s time to ring - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to set the ring time - ! \item[RingTime] - ! The {\tt ESMF\_Alarm}'s ring time to set - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.5.1, TMG4.7, TMG4.8 - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmSetRingTime not supported' ) - end subroutine ESMF_AlarmSetRingTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmGet - Get an alarm's parameters -- compatibility with ESMF 2.0.1 - ! - ! !INTERFACE: - subroutine ESMF_AlarmGet(alarm, name, RingTime, PrevRingTime, RingInterval, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - character(len=*), intent(out), optional :: name - type(ESMF_Time), intent(out), optional :: RingTime - type(ESMF_Time), intent(out), optional :: PrevRingTime - type(ESMF_TimeInterval), intent(out), optional :: RingInterval - integer, intent(out), optional :: rc - integer :: ierr - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Alarm}'s previous ring time - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to get - ! \item[ringTime] - ! The ring time for a one-shot alarm or the next repeating alarm. - ! \item[ringInterval] - ! The ring interval for repeating (interval) alarms. - ! \item[PrevRingTime] - ! The {\tt ESMF\_Alarm}'s previous ring time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.7, TMG4.8 - !EOP - - ierr = ESMF_SUCCESS - - IF ( PRESENT(name) ) THEN - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - name = alarm%alarmint%name - ELSE - ierr = ESMF_FAILURE - END IF - ENDIF - IF ( PRESENT(PrevRingTime) ) THEN - CALL ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc=ierr) - ENDIF - IF ( PRESENT(RingTime) ) THEN - CALL ESMF_AlarmGetRingTime(alarm, RingTime, rc=ierr) - ENDIF - IF ( PRESENT(RingInterval) ) THEN - CALL ESMF_AlarmGetRingInterval(alarm, RingInterval, rc=ierr) - ENDIF - - IF ( PRESENT(rc) ) THEN - rc = ierr - ENDIF - - end subroutine ESMF_AlarmGet - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmGetPrevRingTime - Get an alarm's previous ring time - ! - ! !INTERFACE: - subroutine ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - type(ESMF_Time), intent(out) :: PrevRingTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Alarm}'s previous ring time - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to get the previous ring time - ! \item[PrevRingTime] - ! The {\tt ESMF\_Alarm}'s previous ring time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.7, TMG4.8 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - PrevRingTime = alarm%alarmint%PrevRingTime - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end subroutine ESMF_AlarmGetPrevRingTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmSetPrevRingTime - Set an alarm's previous ring time - ! - ! !INTERFACE: - subroutine ESMF_AlarmSetPrevRingTime(alarm, PrevRingTime, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(out) :: alarm - type(ESMF_Time), intent(in) :: PrevRingTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Alarm}'s previous ring time - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to set the previous ring time - ! \item[PrevRingTime] - ! The {\tt ESMF\_Alarm}'s previous ring time to set - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.7, TMG4.8 - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmSetPrevRingTime not supported' ) - end subroutine ESMF_AlarmSetPrevRingTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmGetStopTime - Get an alarm's stop time - ! - ! !INTERFACE: - subroutine ESMF_AlarmGetStopTime(alarm, StopTime, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - type(ESMF_Time), intent(out) :: StopTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Alarm}'s stop time - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to get the stop time - ! \item[StopTime] - ! The {\tt ESMF\_Alarm}'s stop time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.5.2, TMG4.7 - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmGetStopTime not supported' ) - end subroutine ESMF_AlarmGetStopTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmSetStopTime - Set an alarm's stop time - ! - ! !INTERFACE: - subroutine ESMF_AlarmSetStopTime(alarm, StopTime, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(out) :: alarm - type(ESMF_Time), intent(in) :: StopTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Alarm}'s stop time - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to set the stop time - ! \item[StopTime] - ! The {\tt ESMF\_Alarm}'s stop time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.5.2, TMG4.7 - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmSetStopTime not supported' ) - end subroutine ESMF_AlarmSetStopTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmEnable - Enables an alarm - - ! !INTERFACE: - subroutine ESMF_AlarmEnable(alarm, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Enables an {\tt ESMF\_Alarm} to function - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to enable - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG4.5.3 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - alarm%alarmint%Enabled = .TRUE. - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end subroutine ESMF_AlarmEnable - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmDisable - Disables an alarm - - ! !INTERFACE: - subroutine ESMF_AlarmDisable(alarm, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Disables an {\tt ESMF\_Alarm} - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to disable - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG4.5.3 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - alarm%alarmint%Enabled = .FALSE. - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end subroutine ESMF_AlarmDisable - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmRingerOn - Turn on an alarm - - - ! !INTERFACE: - subroutine ESMF_AlarmRingerOn(alarm, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Turn on an {\tt ESMF\_Alarm}; sets ringing state - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to turn on - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.6 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - IF ( alarm%alarmint%Enabled ) THEN - alarm%alarmint%Ringing = .TRUE. - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - alarm%alarmint%Ringing = .FALSE. - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - - end subroutine ESMF_AlarmRingerOn - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmRingerOff - Turn off an alarm - - ! !INTERFACE: - subroutine ESMF_AlarmRingerOff(alarm, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Turn off an {\tt ESMF\_Alarm}; unsets ringing state - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to turn off - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG4.6 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - alarm%alarmint%Ringing = .FALSE. - IF ( alarm%alarmint%Enabled ) THEN - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end subroutine ESMF_AlarmRingerOff - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmIsRinging - Check if alarm is ringing - - ! !INTERFACE: - function ESMF_AlarmIsRinging(alarm, rc) - ! - ! !RETURN VALUE: - logical :: ESMF_AlarmIsRinging - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Check if {\tt ESMF\_Alarm} is ringing. - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to check for ringing state - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG4.4 - !EOP - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - IF ( alarm%alarmint%Enabled ) THEN - ESMF_AlarmIsRinging = alarm%alarmint%Ringing - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - ESMF_AlarmIsRinging = .FALSE. - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - end function ESMF_AlarmIsRinging - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmCheckRingTime - Method used by a clock to check whether to trigger an alarm - ! - ! !INTERFACE: - function ESMF_AlarmCheckRingTime(alarm, ClockCurrTime, positive, rc) - ! - ! !RETURN VALUE: - logical :: ESMF_AlarmCheckRingTime - ! - ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm - type(ESMF_Time), intent(in) :: ClockCurrTime - integer, intent(in) :: positive - integer, intent(out), optional :: rc - ! - ! !DESCRIPTION: - ! Main method used by a {\tt ESMF\_Clock} to check whether to trigger - ! the {\tt ESMF\_Alarm} - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to check if time to ring - ! \item[ClockCurrTime] - ! The {\tt ESMF\_Clock}'s current time - ! \item[positive] - ! Whether to check ring time in the positive or negative direction - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG4.4, TMG4.6 - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmCheckRingTime not supported' ) - ESMF_AlarmCheckRingTime = .FALSE. ! keep compilers happy - end function ESMF_AlarmCheckRingTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmEQ - Compare two alarms for equality - ! - ! !INTERFACE: - function ESMF_AlarmEQ(alarm1, alarm2) - ! - ! !RETURN VALUE: - logical :: ESMF_AlarmEQ - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm1 - type(ESMF_Alarm), intent(in) :: alarm2 - - ! !DESCRIPTION: - ! Compare two alarms for equality; return true if equal, false otherwise - ! Maps to overloaded (==) operator interface function - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm1] - ! The first {\tt ESMF\_Alarm} to compare - ! \item[alarm2] - ! The second {\tt ESMF\_Alarm} to compare - ! \end{description} - ! - ! !REQUIREMENTS: - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmEQ not supported ' ) - ESMF_AlarmEQ = .FALSE. ! keep compilers happy - end function ESMF_AlarmEQ - - !------------------------------------------------------------------------------ - ! - ! This section defines the overridden Read, Write, Validate and Print methods - ! from the ESMF_Base class - ! - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmRead - restores an alarm - - ! !INTERFACE: - subroutine ESMF_AlarmRead(alarm, RingInterval, RingTime, & - PrevRingTime, StopTime, Ringing, & - Enabled, ID, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(out) :: alarm - type(ESMF_TimeInterval), intent(in) :: RingInterval - type(ESMF_Time), intent(in) :: RingTime - type(ESMF_Time), intent(in) :: PrevRingTime - type(ESMF_Time), intent(in) :: StopTime - logical, intent(in) :: Ringing - logical, intent(in) :: Enabled - integer, intent(in) :: ID - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Restores an {\tt ESMF\_Alarm} - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to restore - ! \item[RingInterval] - ! The ring interval for repeating alarms - ! \item[RingTime] - ! Ring time for one-shot or first repeating alarm - ! \item[PrevRingTime] - ! The {\tt ESMF\_Alarm}'s previous ring time - ! \item[StopTime] - ! Stop time for repeating alarms - ! \item[Ringing] - ! The {\tt ESMF\_Alarm}'s ringing state - ! \item[Enabled] - ! {\tt ESMF\_Alarm} enabled/disabled - ! \item[ID] - ! The {\tt ESMF\_Alarm}'s ID - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmRead not supported' ) - end subroutine ESMF_AlarmRead - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmWrite - saves an alarm - - ! !INTERFACE: - subroutine ESMF_AlarmWrite(alarm, RingInterval, RingTime, & - PrevRingTime, StopTime, Ringing, & - Enabled, ID, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - type(ESMF_TimeInterval), intent(out) :: RingInterval - type(ESMF_Time), intent(out) :: RingTime - type(ESMF_Time), intent(out) :: PrevRingTime - type(ESMF_Time), intent(out) :: StopTime - logical, intent(out) :: Ringing - logical, intent(out) :: Enabled - integer, intent(out) :: ID - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Saves an {\tt ESMF\_Alarm} - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! The object instance to save - ! \item[RingInterval] - ! Ring interval for repeating alarms - ! \item[RingTime] - ! Ring time for one-shot or first repeating alarm - ! \item[PrevRingTime] - ! The {\tt ESMF\_Alarm}'s previous ring time - ! \item[StopTime] - ! Stop time for repeating alarms - ! \item[Ringing] - ! The {\tt ESMF\_Alarm}'s ringing state - ! \item[Enabled] - ! {\tt ESMF\_Alarm} enabled/disabled - ! \item[ID] - ! The {\tt ESMF\_Alarm}'s ID - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmWrite not supported' ) - end subroutine ESMF_AlarmWrite - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmValidate - Validate an Alarm's properties - - ! !INTERFACE: - subroutine ESMF_AlarmValidate(alarm, opts, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - character (len=*), intent(in), optional :: opts - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Perform a validation check on a {\tt ESMF\_Alarm}'s properties - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! {\tt ESMF\_Alarm} to validate - ! \item[{[opts]}] - ! Validate options - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - CALL wrf_error_fatal( 'ESMF_AlarmValidate not supported' ) - end subroutine ESMF_AlarmValidate - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_AlarmPrint - Print out an Alarm's properties - - ! !INTERFACE: - subroutine ESMF_AlarmPrint(alarm, opts, rc) - - ! !ARGUMENTS: - type(ESMF_Alarm), intent(in) :: alarm - character (len=*), intent(in), optional :: opts - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! To support testing/debugging, print out a {\tt ESMF\_Alarm}'s - ! properties. - ! - ! The arguments are: - ! \begin{description} - ! \item[alarm] - ! {\tt ESMF\_Alarm} to print out - ! \item[{[opts]}] - ! Print options - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - integer :: ierr - type(ESMF_Time) :: ringtime - type(ESMF_Time) :: prevringtime - type(ESMF_TimeInterval) :: ringinterval - character(len=256) :: name - - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - IF ( alarm%alarmint%RingTimeSet )THEN - call ESMF_AlarmGet( alarm, name=name, ringtime=ringtime, & - prevringtime=prevringtime, rc=ierr ) - IF ( PRESENT(rc) .AND. (ierr /= ESMF_SUCCESS) )THEN - rc = ierr - END IF - print *, 'Alarm name: ', trim(name) - print *, 'Next ring time' - call ESMF_TimePrint( ringtime ) - print *, 'Previous ring time' - call ESMF_TimePrint( prevringtime ) - END IF - IF ( alarm%alarmint%RingIntervalSet )THEN - call ESMF_AlarmGet( alarm, ringinterval=ringinterval, rc=ierr ) - IF ( PRESENT(rc) .AND. (ierr /= ESMF_SUCCESS) )THEN - rc = ierr - END IF - print *, 'Ring Interval' - call ESMF_TimeIntervalPrint( ringinterval ) - END IF - END IF - - end subroutine ESMF_AlarmPrint - - !------------------------------------------------------------------------------ - -end module ESMF_AlarmMod diff --git a/src/esmf_wrf_timemgr/ESMF_BaseMod.F90 b/src/esmf_wrf_timemgr/ESMF_BaseMod.F90 deleted file mode 100644 index 435ca8d..0000000 --- a/src/esmf_wrf_timemgr/ESMF_BaseMod.F90 +++ /dev/null @@ -1,1089 +0,0 @@ -! $Id$ -! -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -! ESMF Base Module -! -! (all lines between the !BOP and !EOP markers will be included in the -! automated document processing.) -!------------------------------------------------------------------------------ - -!------------------------------------------------------------------------------ -! module definition - - module ESMF_BaseMod - -!BOP -! !MODULE: ESMF_BaseMod - Base class for all ESMF classes -! -! !DESCRIPTION: -! -! The code in this file implements the Base defined type -! and functions which operate on all types. This is an -! interface to the actual C++ base class implementation in the ../src dir. -! -! See the ESMF Developers Guide document for more details. -! -!------------------------------------------------------------------------------ - -! !USES: - implicit none -! -! !PRIVATE TYPES: - private - -!------------------------------------------------------------------------------ -! -! Global integer parameters, used frequently - - integer, parameter :: ESMF_SUCCESS = 0, ESMF_FAILURE = -1 - integer, parameter :: ESMF_MAXSTR = 128 - integer, parameter :: ESMF_MAXDIM = 7, & - ESMF_MAXDECOMPDIM=3, & - ESMF_MAXGRIDDIM=2 - - integer, parameter :: ESMF_MAJOR_VERSION = 2 - integer, parameter :: ESMF_MINOR_VERSION = 2 - integer, parameter :: ESMF_REVISION = 3 - integer, parameter :: ESMF_PATCHLEVEL = 0 - character(32), parameter :: ESMF_VERSION_STRING = "2.2.3" - -!------------------------------------------------------------------------------ -! - type ESMF_Status - private - integer :: status - end type - - type(ESMF_Status), parameter :: ESMF_STATE_UNINIT = ESMF_Status(1), & - ESMF_STATE_READY = ESMF_Status(2), & - ESMF_STATE_UNALLOCATED = ESMF_Status(3), & - ESMF_STATE_ALLOCATED = ESMF_Status(4), & - ESMF_STATE_BUSY = ESMF_Status(5), & - ESMF_STATE_INVALID = ESMF_Status(6) - -!------------------------------------------------------------------------------ -! - type ESMF_Pointer - private - integer*8 :: ptr - end type - - type(ESMF_Pointer), parameter :: ESMF_NULL_POINTER = ESMF_Pointer(0), & - ESMF_BAD_POINTER = ESMF_Pointer(-1) - - -!------------------------------------------------------------------------------ -! - !! TODO: I believe if we define an assignment(=) operator to convert - !! a datatype into integer, then we could use the type and kind as - !! targets in a select case() statement and make the contents private. - !! (see pg 248 of the "big book") - type ESMF_DataType - !!private - integer :: dtype - end type - - type(ESMF_DataType), parameter :: ESMF_DATA_INTEGER = ESMF_DataType(1), & - ESMF_DATA_REAL = ESMF_DataType(2), & - ESMF_DATA_LOGICAL = ESMF_DataType(3), & - ESMF_DATA_CHARACTER = ESMF_DataType(4) - -!------------------------------------------------------------------------------ - - integer, parameter :: & - ESMF_KIND_I1 = selected_int_kind(2), & - ESMF_KIND_I2 = selected_int_kind(4), & - ESMF_KIND_I4 = selected_int_kind(9), & - ESMF_KIND_I8 = selected_int_kind(18), & - ESMF_KIND_R4 = selected_real_kind(3,25), & - ESMF_KIND_R8 = selected_real_kind(6,45), & - ESMF_KIND_C8 = selected_real_kind(3,25), & - ESMF_KIND_C16 = selected_real_kind(6,45) - -!------------------------------------------------------------------------------ - - type ESMF_DataValue - private - type(ESMF_DataType) :: dt - integer :: rank - ! how do you do values of all types here ? TODO - ! in C++ i'd do a union w/ overloaded access funcs - integer :: vi - !integer, dimension (:), pointer :: vip - !real :: vr - !real, dimension (:), pointer :: vrp - !logical :: vl - !logical, pointer :: vlp - !character (len=ESMF_MAXSTR) :: vc - !character, pointer :: vcp - end type - -!------------------------------------------------------------------------------ -! - type ESMF_Attribute - private - character (len=ESMF_MAXSTR) :: attr_name - type (ESMF_DataType) :: attr_type - type (ESMF_DataValue) :: attr_value - end type - -!------------------------------------------------------------------------------ -! - !! TODO: this should be a shallow object, with a simple init() and - !! get() function, and the contents should go back to being private. - type ESMF_AxisIndex -! !!private - integer :: l - integer :: r - integer :: max - integer :: decomp - integer :: gstart - end type - - !! TODO: same comment as above. - type ESMF_MemIndex -! !!private - integer :: l - integer :: r - integer :: str - integer :: num - end type - -!------------------------------------------------------------------------------ -! - type ESMF_BasePointer - private - integer*8 :: base_ptr - end type - - integer :: global_count = 0 - -!------------------------------------------------------------------------------ -! -! ! WARNING: must match corresponding values in ../include/ESMC_Base.h - type ESMF_Logical - private - integer :: value - end type - - type(ESMF_Logical), parameter :: ESMF_TF_UNKNOWN = ESMF_Logical(1), & - ESMF_TF_TRUE = ESMF_Logical(2), & - ESMF_TF_FALSE = ESMF_Logical(3) - -!------------------------------------------------------------------------------ -! - type ESMF_Base - private - integer :: ID - integer :: ref_count - type (ESMF_Status) :: base_status - character (len=ESMF_MAXSTR) :: name - end type - -! !PUBLIC TYPES: - - public ESMF_STATE_INVALID -! public ESMF_STATE_UNINIT, ESMF_STATE_READY, & -! ESMF_STATE_UNALLOCATED, ESMF_STATE_ALLOCATED, & -! ESMF_STATE_BUSY - - public ESMF_DATA_INTEGER, ESMF_DATA_REAL, & - ESMF_DATA_LOGICAL, ESMF_DATA_CHARACTER - - public ESMF_KIND_I1, ESMF_KIND_I2, ESMF_KIND_I4, ESMF_KIND_I8, & - ESMF_KIND_R4, ESMF_KIND_R8, ESMF_KIND_C8, ESMF_KIND_C16 - - public ESMF_NULL_POINTER, ESMF_BAD_POINTER - - - public ESMF_FAILURE, ESMF_SUCCESS - public ESMF_MAXSTR - public ESMF_MAXDIM, ESMF_MAXDECOMPDIM, ESMF_MAXGRIDDIM - - public ESMF_MAJOR_VERSION, ESMF_MINOR_VERSION, ESMF_REVISION - public ESMF_VERSION_STRING - - public ESMF_Status, ESMF_Pointer, ESMF_DataType - public ESMF_DataValue, ESMF_Attribute -! public ESMF_MemIndex -! public ESMF_BasePointer - public ESMF_Base - - public ESMF_AxisIndex, ESMF_AxisIndexGet -! public ESMF_AxisIndexInit - public ESMF_Logical -! public ESMF_TF_TRUE, ESMF_TF_FALSE - -! !PUBLIC MEMBER FUNCTIONS: -! -! !DESCRIPTION: -! The following routines apply to any type in the system. -! The attribute routines can be inherited as-is. The other -! routines need to be specialized by the higher level objects. -! -! Base class methods -! public ESMF_BaseInit - -! public ESMF_BaseGetConfig -! public ESMF_BaseSetConfig - -! public ESMF_BaseGetInstCount - -! public ESMF_BaseSetID -! public ESMF_BaseGetID - -! public ESMF_BaseSetRefCount -! public ESMF_BaseGetRefCount - -! public ESMF_BaseSetStatus -! public ESMF_BaseGetStatus - -! Virtual methods to be defined by derived classes -! public ESMF_Read -! public ESMF_Write -! public ESMF_Validate -! public ESMF_Print - -! Attribute methods - public ESMF_AttributeSet - public ESMF_AttributeGet - public ESMF_AttributeGetCount - public ESMF_AttributeGetbyNumber - public ESMF_AttributeGetNameList - public ESMF_AttributeSetList - public ESMF_AttributeGetList - public ESMF_AttributeSetObjectList - public ESMF_AttributeGetObjectList - public ESMF_AttributeCopy - public ESMF_AttributeCopyAll - -! Misc methods - public ESMF_SetName - public ESMF_GetName - public ESMF_SetPointer - public ESMF_SetNullPointer - public ESMF_GetPointer - -! Print methods for calling by higher level print functions -! (they have little formatting other than the actual values) - public ESMF_StatusString, ESMF_DataTypeString - -! Overloaded = operator functions - public operator(.eq.), operator(.ne.), assignment(=) -! -! -!EOP - -!------------------------------------------------------------------------------ -! leave the following line as-is; it will insert the cvs ident string -! into the object file for tracking purposes. - character(*), parameter, private :: version = & - '$Id$' -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ - -! overload .eq. & .ne. with additional derived types so you can compare -! them as if they were simple integers. - - -interface operator (.eq.) - module procedure ESMF_sfeq - module procedure ESMF_dteq - module procedure ESMF_pteq - module procedure ESMF_tfeq - module procedure ESMF_aieq -end interface - -interface operator (.ne.) - module procedure ESMF_sfne - module procedure ESMF_dtne - module procedure ESMF_ptne - module procedure ESMF_tfne - module procedure ESMF_aine -end interface - -interface assignment (=) - module procedure ESMF_dtas - module procedure ESMF_ptas -end interface - -!------------------------------------------------------------------------------ - - contains - -!------------------------------------------------------------------------------ -! function to compare two ESMF_Status flags to see if they're the same or not - -function ESMF_sfeq(sf1, sf2) - logical ESMF_sfeq - type(ESMF_Status), intent(in) :: sf1, sf2 - - ESMF_sfeq = (sf1%status .eq. sf2%status) -end function - -function ESMF_sfne(sf1, sf2) - logical ESMF_sfne - type(ESMF_Status), intent(in) :: sf1, sf2 - - ESMF_sfne = (sf1%status .ne. sf2%status) -end function - -!------------------------------------------------------------------------------ -! function to compare two ESMF_DataTypes to see if they're the same or not - -function ESMF_dteq(dt1, dt2) - logical ESMF_dteq - type(ESMF_DataType), intent(in) :: dt1, dt2 - - ESMF_dteq = (dt1%dtype .eq. dt2%dtype) -end function - -function ESMF_dtne(dt1, dt2) - logical ESMF_dtne - type(ESMF_DataType), intent(in) :: dt1, dt2 - - ESMF_dtne = (dt1%dtype .ne. dt2%dtype) -end function - -subroutine ESMF_dtas(intval, dtval) - integer, intent(out) :: intval - type(ESMF_DataType), intent(in) :: dtval - - intval = dtval%dtype -end subroutine - - -!------------------------------------------------------------------------------ -! function to compare two ESMF_Pointers to see if they're the same or not - -function ESMF_pteq(pt1, pt2) - logical ESMF_pteq - type(ESMF_Pointer), intent(in) :: pt1, pt2 - - ESMF_pteq = (pt1%ptr .eq. pt2%ptr) -end function - -function ESMF_ptne(pt1, pt2) - logical ESMF_ptne - type(ESMF_Pointer), intent(in) :: pt1, pt2 - - ESMF_ptne = (pt1%ptr .ne. pt2%ptr) -end function - -subroutine ESMF_ptas(ptval, intval) - type(ESMF_Pointer), intent(out) :: ptval - integer, intent(in) :: intval - - ptval%ptr = intval -end subroutine - -!------------------------------------------------------------------------------ -! function to compare two ESMF_Logicals to see if they're the same or not -! also need assignment to real f90 logical? - -function ESMF_tfeq(tf1, tf2) - logical ESMF_tfeq - type(ESMF_Logical), intent(in) :: tf1, tf2 - - ESMF_tfeq = (tf1%value .eq. tf2%value) -end function - -function ESMF_tfne(tf1, tf2) - logical ESMF_tfne - type(ESMF_Logical), intent(in) :: tf1, tf2 - - ESMF_tfne = (tf1%value .ne. tf2%value) -end function - -!------------------------------------------------------------------------------ -! function to compare two ESMF_AxisIndex to see if they're the same or not - -function ESMF_aieq(ai1, ai2) - logical ESMF_aieq - type(ESMF_AxisIndex), intent(in) :: ai1, ai2 - - ESMF_aieq = ((ai1%l .eq. ai2%l) .and. & - (ai1%r .eq. ai2%r) .and. & - (ai1%max .eq. ai2%max) .and. & - (ai1%decomp .eq. ai2%decomp) .and. & - (ai1%gstart .eq. ai2%gstart)) - -end function - -function ESMF_aine(ai1, ai2) - logical ESMF_aine - type(ESMF_AxisIndex), intent(in) :: ai1, ai2 - - ESMF_aine = ((ai1%l .ne. ai2%l) .or. & - (ai1%r .ne. ai2%r) .or. & - (ai1%max .ne. ai2%max) .or. & - (ai1%decomp .ne. ai2%decomp) .or. & - (ai1%gstart .ne. ai2%gstart)) - -end function - -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -! -! Base methods -! -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -!BOP -! !IROUTINE: ESMF_BaseInit - initialize a Base object -! -! !INTERFACE: - subroutine ESMF_BaseInit(base, rc) -! -! !ARGUMENTS: - type(ESMF_Base) :: base - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Set initial state on a Base object. -! -! \begin{description} -! \item [base] -! In the Fortran interface, this must in fact be a {\tt Base} -! derived type object. It is expected that all specialized -! derived types will include a {\tt Base} object as the first -! entry. -! \item [{[rc]}] -! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. -! -! \end{description} -! -!EOP - - logical :: rcpresent ! Return code present - -! !Initialize return code - rcpresent = .FALSE. - if(present(rc)) then - rcpresent = .TRUE. - rc = ESMF_FAILURE - endif - - global_count = global_count + 1 - base%ID = global_count - base%ref_count = 1 - base%base_status = ESMF_STATE_READY - base%name = "undefined" - - if (rcpresent) rc = ESMF_SUCCESS - - end subroutine ESMF_BaseInit - -!------------------------------------------------------------------------------ -!BOP -! !IROUTINE: ESMF_SetName - set the name of this object -! -! !INTERFACE: - subroutine ESMF_SetName(anytype, name, namespace, rc) -! -! !ARGUMENTS: - type(ESMF_Base) :: anytype - character (len = *), intent(in), optional :: name - character (len = *), intent(in), optional :: namespace - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Associate a name with any object in the system. -! -! \begin{description} -! \item [anytype] -! In the Fortran interface, this must in fact be a {\tt Base} -! derived type object. It is expected that all specialized -! derived types will include a {\tt Base} object as the first -! entry. -! \item [[name]] -! Object name. An error will be returned if a duplicate name -! is specified. If a name is not given a unique name will be -! generated and can be queried by the {\tt ESMF_GetName} routine. -! \item [[namespace]] -! Object namespace (e.g. "Application", "Component", "Grid", etc). -! If given, the name will be checked that it is unique within -! this namespace. If not given, the generated name will be -! unique within this namespace. If namespace is not specified, -! a default "global" namespace will be assumed and the same rules -! for names will be followed. -! \item [[rc]] -! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. -! -! \end{description} -! -! - -! -!EOP -! !REQUIREMENTS: FLD1.5, FLD1.5.3 - logical :: rcpresent ! Return code present - character (len = ESMF_MAXSTR) :: ournamespace ! Namespace if not given - character (len = ESMF_MAXSTR) :: defaultname ! Name if not given - integer, save :: seqnum = 0 ! HACK - generate uniq names - ! but not coordinated across procs - -! !Initialize return code - rcpresent = .FALSE. - if(present(rc)) then - rcpresent = .TRUE. - rc = ESMF_FAILURE - endif - -! ! TODO: this code should generate a unique name if a name -! ! is not given. If a namespace is given, the name has to -! ! be unique within that namespace. Example namespaces could -! ! be: Applications, Components, Fields/Bundles, Grids. -! -! ! Construct a default namespace if one is not given - if((.not. present(namespace)) .or. (namespace .eq. "")) then - ournamespace = "global" - else - ournamespace = namespace - endif -! ! Construct a default name if one is not given - if((.not. present(name)) .or. (name .eq. "")) then - - write(defaultname, 20) trim(ournamespace), seqnum -20 format(A,I3.3) - seqnum = seqnum + 1 - anytype%name = defaultname - else - anytype%name = name - endif - - if (rcpresent) rc = ESMF_SUCCESS - - end subroutine ESMF_SetName - -!------------------------------------------------------------------------- -!BOP -! !IROUTINE: ESMF_GetName - get the name of this object -! -! !INTERFACE: - subroutine ESMF_GetName(anytype, name, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF object/type - character (len = *), intent(out) :: name ! object/type name - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Return the name of any type in the system. - -! -!EOP -! !REQUIREMENTS: FLD1.5, FLD1.5.3 - - name = anytype%name - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_GetName - - -!------------------------------------------------------------------------- -!BOP -! !IROUTINE: ESMF_AttributeSet - set attribute on an ESMF type -! -! !INTERFACE: - subroutine ESMF_AttributeSet(anytype, name, value, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - character (len = *), intent(in) :: name ! attribute name - type(ESMF_DataValue), intent(in) :: value ! attribute value - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Associate a (name,value) pair with any type in the system. - -! -!EOP -! !REQUIREMENTS: FLD1.5, FLD1.5.3 - - end subroutine ESMF_AttributeSet - - -!------------------------------------------------------------------------- -!BOP -! !IROUTINE: ESMF_AttributeGet - get attribute from an ESMF type -! -! !INTERFACE: - subroutine ESMF_AttributeGet(anytype, name, type, value, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - character (len = *), intent(in) :: name ! attribute name - type(ESMF_DataType), intent(out) :: type ! all possible data types - type(ESMF_DataValue), intent(out) :: value ! attribute value - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: - -! -!EOP -! !REQUIREMENTS: FLD1.5.1, FLD1.5.3 - - end subroutine ESMF_AttributeGet - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ESMF_AttributeGetCount - get an ESMF object's number of attributes -! -! !INTERFACE: - subroutine ESMF_AttributeGetCount(anytype, count, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - integer, intent(out) :: count ! attribute count - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Returns number of attributes present. - -! -!EOP -! !REQUIREMENTS: FLD1.7.5 - - end subroutine ESMF_AttributeGetCount - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ESMF_AttributeGetbyNumber - get an ESMF object's attribute by num ber -! -! !INTERFACE: - subroutine ESMF_AttributeGetbyNumber(anytype, number, name, type, value, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - integer, intent(in) :: number ! attribute number - character (len = *), intent(in) :: name ! attribute name - type(ESMF_DataType), intent(out) :: type ! all possible data types - type(ESMF_DataValue), intent(out) :: value ! attribute value - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Allows the caller to get attributes by number instead of by name. -! This can be useful in iterating through all attributes in a loop. -! -!EOP -! !REQUIREMENTS: - - end subroutine ESMF_AttributeGetbyNumber - - -!------------------------------------------------------------------------- -!BOP -! -!IROUTINE: ESMF_AttributeGetNameList - get an ESMF object's attribute name list -! -! !INTERFACE: - subroutine ESMF_AttributeGetNameList(anytype, count, namelist, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - integer, intent(out) :: count ! attribute count - character (len = *), dimension (:), intent(out) :: namelist ! attribute names - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Return a list of all attribute names without returning the values. - -! -!EOP -! !REQUIREMENTS: FLD1.7.3 - - end subroutine ESMF_AttributeGetNameList - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ESMF_AttributeSetList - set an ESMF object's attributes -! -! !INTERFACE: - subroutine ESMF_AttributeSetList(anytype, namelist, valuelist, rc) - -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - character (len = *), dimension (:), intent(in) :: namelist ! attribute names - type(ESMF_DataValue), dimension (:), intent(in) :: valuelist ! attribute values - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Set multiple attributes on an object in one call. Depending on what is -! allowed by the interface, all attributes may have to have the same type. -! -!EOP -! !REQUIREMENTS: (none. added for completeness) - - end subroutine ESMF_AttributeSetList - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ESMF_AttributeGetList - get an ESMF object's attributes -! -! !INTERFACE: - subroutine ESMF_AttributeGetList(anytype, namelist, typelist, valuelist, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: anytype ! any ESMF type - character (len = *), dimension (:), intent(in) :: namelist ! attribute names - type(ESMF_DataType), dimension (:), intent(out) :: typelist ! all possible data types - type(ESMF_DataValue), dimension (:), intent(out) :: valuelist ! attribute values - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Get multiple attributes from an object in a single call. - -! -!EOP -! !REQUIREMENTS: FLD1.7.4 - - end subroutine ESMF_AttributeGetList - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ESMF_AttributeSetObjectList - set an attribute on multiple ESMF objects -! -! !INTERFACE: - subroutine ESMF_AttributeSetObjectList(anytypelist, name, value, rc) -! -! !ARGUMENTS: - type(ESMF_Base), dimension (:), intent(in) :: anytypelist ! list of any ESMF types - character (len = *), intent(in) :: name ! attribute name - type(ESMF_DataValue), dimension (:), intent(in) :: value ! attribute value - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Set the same attribute on multiple objects in one call. - -! -!EOP -! !REQUIREMENTS: FLD1.5.5 (pri 2) - - end subroutine ESMF_AttributeSetObjectList - - -!------------------------------------------------------------------------- -!BOP -! -! -! !IROUTINE: ESMF_AttributeGetObjectList - get an attribute from multiple ESMF objects -! -! !INTERFACE: - subroutine ESMF_AttributeGetObjectList(anytypelist, name, typelist, valuelist, rc) -! -! !ARGUMENTS: - type(ESMF_Base), dimension (:), intent(in) :: anytypelist ! list of any ESMF types - character (len = *), intent(in) :: name ! attribute name - type(ESMF_DataType), dimension (:), intent(out) :: typelist ! all possible data types - type(ESMF_DataValue), dimension (:), intent(out) :: valuelist ! attribute values - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! Get the same attribute name from multiple objects in one call. - -! -!EOP -! !REQUIREMENTS: FLD1.5.5 (pri 2) - - end subroutine ESMF_AttributeGetObjectList - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ESMF_AttributeCopy - copy an attribute between two objects -! -! !INTERFACE: - subroutine ESMF_AttributeCopy(name, source, destination, rc) -! -! !ARGUMENTS: - character (len = *), intent(in) :: name ! attribute name - type(ESMF_Base), intent(in) :: source ! any ESMF type - type(ESMF_Base), intent(in) :: destination ! any ESMF type - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! The specified attribute associated with the source object is -! copied to the destination object. << does this assume overwriting the -! attribute if it already exists in the output or does this require yet -! another arg to say what to do with collisions? >> - - -! -!EOP -! !REQUIREMENTS: FLD1.5.4 - - end subroutine ESMF_AttributeCopy - - -!------------------------------------------------------------------------- -!BOP -! -!IROUTINE: ESMC_AttributeCopyAll - copy attributes between two objects - -! -! !INTERFACE: - subroutine ESMF_AttributeCopyAll(source, destination, rc) -! -! !ARGUMENTS: - type(ESMF_Base), intent(in) :: source ! any ESMF type - type(ESMF_Base), intent(in) :: destination ! any ESMF type - integer, intent(out), optional :: rc ! return code - -! -! !DESCRIPTION: -! All attributes associated with the source object are copied to the -! destination object. Some attributes will have to be considered -! {\tt read only} and won't be updated by this call. (e.g. an attribute -! like {\tt name} must be unique and therefore can't be duplicated.) - -! -!EOP -! !REQUIREMENTS: FLD1.5.4 - - end subroutine ESMF_AttributeCopyAll - -!========================================================================= -! Misc utility routines, perhaps belongs in a utility file? -!------------------------------------------------------------------------- -!BOP -! -!IROUTINE: ESMC_AxisIndexInit - initialize an AxisIndex object - -! -! !INTERFACE: - subroutine ESMF_AxisIndexInit(ai, l, r, max, decomp, gstart, rc) -! -! !ARGUMENTS: - type(ESMF_AxisIndex), intent(inout) :: ai - integer, intent(in) :: l, r, max, decomp, gstart - integer, intent(out), optional :: rc -! -! !DESCRIPTION: -! Set the contents of an AxisIndex type. - -! -!EOP -! !REQUIREMENTS: - - ai%l = l - ai%r = r - ai%max = max - ai%decomp = decomp - ai%gstart = gstart - - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_AxisIndexInit - -!BOP -! -!IROUTINE: ESMC_AxisIndexInit - initialize an AxisIndex object - -! -! !INTERFACE: - subroutine ESMF_AxisIndexGet(ai, l, r, max, decomp, gstart, rc) -! -! !ARGUMENTS: - type(ESMF_AxisIndex), intent(inout) :: ai - integer, intent(out), optional :: l, r, max, decomp, gstart - integer, intent(out), optional :: rc -! -! !DESCRIPTION: -! Get the contents of an AxisIndex type. - -! -!EOP -! !REQUIREMENTS: - - if (present(l)) l = ai%l - if (present(r)) r = ai%r - if (present(max)) max = ai%max - if (present(decomp)) decomp = ai%decomp - if (present(gstart)) gstart = ai%gstart - - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_AxisIndexGet - -!------------------------------------------------------------------------- -!------------------------------------------------------------------------- -!BOP -! -!IROUTINE: ESMF_SetPointer - set an opaque value - -! -! !INTERFACE: - subroutine ESMF_SetPointer(ptype, contents, rc) -! -! !ARGUMENTS: - type(ESMF_Pointer) :: ptype - integer*8, intent(in) :: contents - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Set the contents of an opaque pointer type. - -! -!EOP -! !REQUIREMENTS: - ptype%ptr = contents - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_SetPointer - -!------------------------------------------------------------------------- -!BOP -! -!IROUTINE: ESMF_SetNullPointer - set an opaque value - -! -! !INTERFACE: - subroutine ESMF_SetNullPointer(ptype, rc) -! -! !ARGUMENTS: - type(ESMF_Pointer) :: ptype - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Set the contents of an opaque pointer type. - -! -!EOP -! !REQUIREMENTS: - integer*8, parameter :: nullp = 0 - - ptype%ptr = nullp - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_SetNullPointer -!------------------------------------------------------------------------- -!BOP -! !IROUTINE: ESMF_GetPointer - get an opaque value -! -! !INTERFACE: - function ESMF_GetPointer(ptype, rc) -! -! !RETURN VALUE: - integer*8 :: ESMF_GetPointer - -! !ARGUMENTS: - type(ESMF_Pointer), intent(in) :: ptype - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Get the contents of an opaque pointer type. - -! -!EOP -! !REQUIREMENTS: - ESMF_GetPointer = ptype%ptr - if (present(rc)) rc = ESMF_SUCCESS - - end function ESMF_GetPointer - -!------------------------------------------------------------------------- -! misc print routines -!------------------------------------------------------------------------- -!BOP -! !IROUTINE: ESMF_StatusString - Return status as a string -! -! !INTERFACE: - subroutine ESMF_StatusString(status, string, rc) -! -! !ARGUMENTS: - type(ESMF_Status), intent(in) :: status - character(len=*), intent(out) :: string - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Return a status variable as a string. - -! -!EOP -! !REQUIREMENTS: - - if (status .eq. ESMF_STATE_UNINIT) string = "Uninitialized" - if (status .eq. ESMF_STATE_READY) string = "Ready" - if (status .eq. ESMF_STATE_UNALLOCATED) string = "Unallocated" - if (status .eq. ESMF_STATE_ALLOCATED) string = "Allocated" - if (status .eq. ESMF_STATE_BUSY) string = "Busy" - if (status .eq. ESMF_STATE_INVALID) string = "Invalid" - - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_StatusString - -!------------------------------------------------------------------------- -!BOP -! !IROUTINE: ESMF_DataTypeString - Return DataType as a string -! -! !INTERFACE: - subroutine ESMF_DataTypeString(datatype, string, rc) -! -! !ARGUMENTS: - type(ESMF_DataType), intent(in) :: datatype - character(len=*), intent(out) :: string - integer, intent(out), optional :: rc - -! -! !DESCRIPTION: -! Return a datatype variable as a string. - -! -!EOP -! !REQUIREMENTS: - - if (datatype .eq. ESMF_DATA_INTEGER) string = "Integer" - if (datatype .eq. ESMF_DATA_REAL) string = "Real" - if (datatype .eq. ESMF_DATA_LOGICAL) string = "Logical" - if (datatype .eq. ESMF_DATA_CHARACTER) string = "Character" - - if (present(rc)) rc = ESMF_SUCCESS - - end subroutine ESMF_DataTypeString - -!------------------------------------------------------------------------- -! -!------------------------------------------------------------------------- -! put Print and Validate skeletons here - but they should be -! overridden by higher level more specialized functions. -!------------------------------------------------------------------------- - - end module ESMF_BaseMod diff --git a/src/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 b/src/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 deleted file mode 100644 index 46f8048..0000000 --- a/src/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 +++ /dev/null @@ -1,459 +0,0 @@ -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF BaseTime Module -module ESMF_BaseTimeMod - ! - !============================================================================== - ! - ! This file contains the BaseTime class definition and all BaseTime class - ! methods. - ! - !------------------------------------------------------------------------------ - ! INCLUDES - -#include - ! - !=============================================================================== - !BOPI - ! !MODULE: ESMF_BaseTimeMod - Base ESMF time definition - ! - ! !DESCRIPTION: - ! Part of Time Manager F90 API wrapper of C++ implemenation - ! - ! This module serves only as the common Time definition inherited - ! by {\tt ESMF\_TimeInterval} and {\tt ESMF\_Time} - ! - ! See {\tt ../include/ESMC\_BaseTime.h} for complete description - ! - !------------------------------------------------------------------------------ - ! !USES: - use ESMF_BaseMod ! ESMF Base class - implicit none - ! - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_BaseTime - ! - ! ! Base class type to match C++ BaseTime class in size only; - ! ! all dereferencing within class is performed by C++ implementation - - type ESMF_BaseTime - integer(ESMF_KIND_I8) :: S ! whole seconds - integer(ESMF_KIND_I8) :: Sn ! fractional seconds, numerator - integer(ESMF_KIND_I8) :: Sd ! fractional seconds, denominator - end type ESMF_BaseTime - - !------------------------------------------------------------------------------ - ! !PUBLIC TYPES: - public ESMF_BaseTime - !------------------------------------------------------------------------------ - ! - ! !PUBLIC MEMBER FUNCTIONS: - ! - ! overloaded operators - public seccmp - public normalize_basetime - public operator(+) - private ESMF_BaseTimeSum - public operator(-) - private ESMF_BaseTimeDifference - public operator(/) - private ESMF_BaseTimeQuotI - private ESMF_BaseTimeQuotI8 - public operator(.EQ.) - private ESMF_BaseTimeEQ - public operator(.NE.) - private ESMF_BaseTimeNE - public operator(.LT.) - private ESMF_BaseTimeLT - public operator(.GT.) - private ESMF_BaseTimeGT - public operator(.LE.) - private ESMF_BaseTimeLE - public operator(.GE.) - private ESMF_BaseTimeGE - - !============================================================================== - ! - ! INTERFACE BLOCKS - ! - !============================================================================== - interface operator(+) - module procedure ESMF_BaseTimeSum - end interface operator(+) - interface operator(-) - module procedure ESMF_BaseTimeDifference - end interface operator(-) - interface operator(/) - module procedure ESMF_BaseTimeQuotI,ESMF_BaseTimeQuotI8 - end interface operator(/) - interface operator(.EQ.) - module procedure ESMF_BaseTimeEQ - end interface operator(.EQ.) - interface operator(.NE.) - module procedure ESMF_BaseTimeNE - end interface operator(.NE.) - interface operator(.LT.) - module procedure ESMF_BaseTimeLT - end interface operator(.LT.) - interface operator(.GT.) - module procedure ESMF_BaseTimeGT - end interface operator(.GT.) - interface operator(.LE.) - module procedure ESMF_BaseTimeLE - end interface operator(.LE.) - interface operator(.GE.) - module procedure ESMF_BaseTimeGE - end interface operator(.GE.) - - - !============================================================================== - -contains - - !============================================================================== - - SUBROUTINE normalize_basetime( basetime ) - ! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match. - ! Also, enforce consistency. - ! YR and MM fields are ignored. - IMPLICIT NONE - TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime - - !PRINT *,'DEBUG: BEGIN normalize_basetime()' - ! Consistency check... - IF ( basetime%Sd < 0 ) THEN - CALL wrf_error_fatal( & - 'normalize_basetime: denominator of seconds cannot be negative' ) - ENDIF - IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN - CALL wrf_error_fatal( & - 'normalize_basetime: denominator of seconds cannot be zero when numerator is non-zero' ) - ENDIF - ! factor so abs(Sn) < Sd - IF ( basetime%Sd > 0 ) THEN - IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN - !PRINT *,'DEBUG: normalize_basetime() A1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - basetime%S = basetime%S + ( basetime%Sn / basetime%Sd ) - basetime%Sn = mod( basetime%Sn, basetime%Sd ) - !PRINT *,'DEBUG: normalize_basetime() A2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - ENDIF - ! change sign of Sn if it does not match S - IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN - !PRINT *,'DEBUG: normalize_basetime() B1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - basetime%S = basetime%S - 1_ESMF_KIND_I8 - basetime%Sn = basetime%Sn + basetime%Sd - !PRINT *,'DEBUG: normalize_basetime() B2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - ENDIF - IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN - !PRINT *,'DEBUG: normalize_basetime() C1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - basetime%S = basetime%S + 1_ESMF_KIND_I8 - basetime%Sn = basetime%Sn - basetime%Sd - !PRINT *,'DEBUG: normalize_basetime() C2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - ENDIF - ENDIF - !PRINT *,'DEBUG: END normalize_basetime()' - END SUBROUTINE normalize_basetime - - !============================================================================== - - ! Add two basetimes - FUNCTION ESMF_BaseTimeSum( basetime1, basetime2 ) - TYPE(ESMF_BaseTime) :: ESMF_BaseTimeSum - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - ! locals - INTEGER (ESMF_KIND_I8) :: Sn1, Sd1, Sn2, Sd2, lcd - ! PRINT *,'DEBUG: BEGIN ESMF_BaseTimeSum()' - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%S = ',basetime1%S - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%Sn = ',basetime1%Sn - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%Sd = ',basetime1%Sd - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%S = ',basetime2%S - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%Sn = ',basetime2%Sn - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%Sd = ',basetime2%Sd - ESMF_BaseTimeSum = basetime1 - ESMF_BaseTimeSum%S = ESMF_BaseTimeSum%S + basetime2%S - Sn1 = basetime1%Sn - Sd1 = basetime1%Sd - Sn2 = basetime2%Sn - Sd2 = basetime2%Sd - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sn1 = ',Sn1 - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sd1 = ',Sd1 - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sn2 = ',Sn2 - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sd2 = ',Sd2 - IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): no fractions' - ESMF_BaseTimeSum%Sn = 0 - ESMF_BaseTimeSum%Sd = 0 - ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN - ESMF_BaseTimeSum%Sn = Sn1 - ESMF_BaseTimeSum%Sd = Sd1 - ELSE IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN - ESMF_BaseTimeSum%Sn = Sn2 - ESMF_BaseTimeSum%Sd = Sd2 - ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN - CALL compute_lcd( Sd1 , Sd2 , lcd ) - ESMF_BaseTimeSum%Sd = lcd - ESMF_BaseTimeSum%Sn = (Sn1 * lcd / Sd1) + (Sn2 * lcd / Sd2) - ENDIF - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%S = ',ESMF_BaseTimeSum%S - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%Sn = ',ESMF_BaseTimeSum%Sn - ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%Sd = ',ESMF_BaseTimeSum%Sd - CALL normalize_basetime( ESMF_BaseTimeSum ) - ! PRINT *,'DEBUG: END ESMF_BaseTimeSum()' - END FUNCTION ESMF_BaseTimeSum - - - ! Subtract two basetimes - FUNCTION ESMF_BaseTimeDifference( basetime1, basetime2 ) - TYPE(ESMF_BaseTime) :: ESMF_BaseTimeDifference - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - ! locals - TYPE(ESMF_BaseTime) :: neg2 - - neg2%S = -basetime2%S - neg2%Sn = -basetime2%Sn - neg2%Sd = basetime2%Sd - - ESMF_BaseTimeDifference = basetime1 + neg2 - - END FUNCTION ESMF_BaseTimeDifference - - - ! Divide basetime by 8-byte integer - FUNCTION ESMF_BaseTimeQuotI8( basetime, divisor ) - TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI8 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime - INTEGER(ESMF_KIND_I8), INTENT(IN) :: divisor - ! locals - INTEGER(ESMF_KIND_I8) :: d, n, dinit - - !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A: S,Sn,Sd = ', & - ! basetime%S,basetime%Sn,basetime%Sd - !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A: divisor = ', divisor - IF ( divisor == 0_ESMF_KIND_I8 ) THEN - CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI8: divide by zero' ) - ENDIF - - !$$$ move to default constructor - ESMF_BaseTimeQuotI8%S = 0 - ESMF_BaseTimeQuotI8%Sn = 0 - ESMF_BaseTimeQuotI8%Sd = 0 - - ! convert to a fraction and divide by multipling the denonminator by - ! the divisor - IF ( basetime%Sd == 0 ) THEN - dinit = 1_ESMF_KIND_I8 - ELSE - dinit = basetime%Sd - ENDIF - n = basetime%S * dinit + basetime%Sn - d = dinit * divisor - !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() B: n,d = ',n,d - CALL simplify( n, d, ESMF_BaseTimeQuotI8%Sn, ESMF_BaseTimeQuotI8%Sd ) - !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() C: S,Sn,Sd = ', & - ! ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd - CALL normalize_basetime( ESMF_BaseTimeQuotI8 ) - !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() D: S,Sn,Sd = ', & - ! ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd - END FUNCTION ESMF_BaseTimeQuotI8 - - ! Divide basetime by integer - FUNCTION ESMF_BaseTimeQuotI( basetime, divisor ) - TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime - INTEGER, INTENT(IN) :: divisor - IF ( divisor == 0 ) THEN - CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI: divide by zero' ) - ENDIF - ESMF_BaseTimeQuotI = basetime / INT( divisor, ESMF_KIND_I8 ) - END FUNCTION ESMF_BaseTimeQuotI - - - ! .EQ. for two basetimes - FUNCTION ESMF_BaseTimeEQ( basetime1, basetime2 ) - LOGICAL :: ESMF_BaseTimeEQ - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - INTEGER :: retval - CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & - basetime2%S, basetime2%Sn, basetime2%Sd, & - retval ) - ESMF_BaseTimeEQ = ( retval .EQ. 0 ) - END FUNCTION ESMF_BaseTimeEQ - - - ! .NE. for two basetimes - FUNCTION ESMF_BaseTimeNE( basetime1, basetime2 ) - LOGICAL :: ESMF_BaseTimeNE - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - INTEGER :: retval - CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & - basetime2%S, basetime2%Sn, basetime2%Sd, & - retval ) - ESMF_BaseTimeNE = ( retval .NE. 0 ) - END FUNCTION ESMF_BaseTimeNE - - - ! .LT. for two basetimes - FUNCTION ESMF_BaseTimeLT( basetime1, basetime2 ) - LOGICAL :: ESMF_BaseTimeLT - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - INTEGER :: retval - CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & - basetime2%S, basetime2%Sn, basetime2%Sd, & - retval ) - ESMF_BaseTimeLT = ( retval .LT. 0 ) - END FUNCTION ESMF_BaseTimeLT - - - ! .GT. for two basetimes - FUNCTION ESMF_BaseTimeGT( basetime1, basetime2 ) - LOGICAL :: ESMF_BaseTimeGT - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - INTEGER :: retval - CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & - basetime2%S, basetime2%Sn, basetime2%Sd, & - retval ) - ESMF_BaseTimeGT = ( retval .GT. 0 ) - END FUNCTION ESMF_BaseTimeGT - - - ! .LE. for two basetimes - FUNCTION ESMF_BaseTimeLE( basetime1, basetime2 ) - LOGICAL :: ESMF_BaseTimeLE - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - INTEGER :: retval - CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & - basetime2%S, basetime2%Sn, basetime2%Sd, & - retval ) - ESMF_BaseTimeLE = ( retval .LE. 0 ) - END FUNCTION ESMF_BaseTimeLE - - - ! .GE. for two basetimes - FUNCTION ESMF_BaseTimeGE( basetime1, basetime2 ) - LOGICAL :: ESMF_BaseTimeGE - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 - TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 - INTEGER :: retval - CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & - basetime2%S, basetime2%Sn, basetime2%Sd, & - retval ) - ESMF_BaseTimeGE = ( retval .GE. 0 ) - END FUNCTION ESMF_BaseTimeGE - - !============================================================================== - - SUBROUTINE compute_lcd( e1, e2, lcd ) - IMPLICIT NONE - INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2 - INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd - INTEGER, PARAMETER :: nprimes = 9 - INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) - INTEGER i - INTEGER(ESMF_KIND_I8) d1, d2, p - - d1 = e1 ; d2 = e2 - IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF - IF ( d1 .EQ. 0 ) d1 = d2 - IF ( d2 .EQ. 0 ) d2 = d1 - IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF - lcd = d1 * d2 - DO i = 1, nprimes - p = primes(i) - DO WHILE (lcd/p .NE. 0 .AND. & - mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0) - lcd = lcd / p - END DO - ENDDO - END SUBROUTINE compute_lcd - - !============================================================================== - - SUBROUTINE simplify( ni, di, no, do ) - IMPLICIT NONE - INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di - INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do - INTEGER, PARAMETER :: nprimes = 9 - INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) - INTEGER(ESMF_KIND_I8) :: pr, d, n - INTEGER :: np - LOGICAL keepgoing - IF ( ni .EQ. 0 ) THEN - do = 1 - no = 0 - RETURN - ENDIF - IF ( mod( di , ni ) .EQ. 0 ) THEN - do = di / ni - no = 1 - RETURN - ENDIF - d = di - n = ni - DO np = 1, nprimes - pr = primes(np) - keepgoing = .TRUE. - DO WHILE ( keepgoing ) - keepgoing = .FALSE. - IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN - d = d / pr - n = n / pr - keepgoing = .TRUE. - ENDIF - ENDDO - ENDDO - do = d - no = n - RETURN - END SUBROUTINE simplify - - !============================================================================== - - ! spaceship operator for seconds + Sn/Sd - SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval - ! - ! !ARGUMENTS: - INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1 - INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2 - ! local - INTEGER(ESMF_KIND_I8) :: lcd, n1, n2 - - n1 = Sn1 - n2 = Sn2 - if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then - CALL compute_lcd( Sd1, Sd2, lcd ) - if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 ) - if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 ) - endif - - if ( S1 .GT. S2 ) retval = 1 - if ( S1 .LT. S2 ) retval = -1 - IF ( S1 .EQ. S2 ) THEN - IF (n1 .GT. n2) retval = 1 - IF (n1 .LT. n2) retval = -1 - IF (n1 .EQ. n2) retval = 0 - ENDIF - END SUBROUTINE seccmp - - !============================================================================== - - end module ESMF_BaseTimeMod diff --git a/src/esmf_wrf_timemgr/ESMF_CalendarMod.F90 b/src/esmf_wrf_timemgr/ESMF_CalendarMod.F90 deleted file mode 100644 index e4202b7..0000000 --- a/src/esmf_wrf_timemgr/ESMF_CalendarMod.F90 +++ /dev/null @@ -1,502 +0,0 @@ -! $Id$ -! -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF Calendar Module - module ESMF_CalendarMod -! -!============================================================================== -! -! This file contains the Calendar class definition and all Calendar class -! methods. -! -!------------------------------------------------------------------------------ -! INCLUDES -#include - -!============================================================================== -!BOPI -! !MODULE: ESMF_CalendarMod -! -! !DESCRIPTION: -! Part of Time Manager F90 API wrapper of C++ implemenation -! -! Defines F90 wrapper entry points for corresponding -! C++ class { \tt ESMC\_Calendar} implementation -! -! See {\tt ../include/ESMC\_Calendar.h} for complete description -! -!------------------------------------------------------------------------------ -! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! inherit from base time class - use ESMF_BaseTimeMod - - implicit none -! -!------------------------------------------------------------------------------ -! !PRIVATE TYPES: - private -!------------------------------------------------------------------------------ - - INTEGER, PARAMETER :: mday(MONTHS_PER_YEAR) & - = (/31,28,31,30,31,30,31,31,30,31,30,31/) - INTEGER, PARAMETER :: mdayleap(MONTHS_PER_YEAR) & - = (/31,29,31,30,31,30,31,31,30,31,30,31/) - INTEGER, DIMENSION(365) :: daym - INTEGER, DIMENSION(366) :: daymleap - INTEGER :: mdaycum(0:MONTHS_PER_YEAR) - INTEGER :: mdayleapcum(0:MONTHS_PER_YEAR) - TYPE(ESMF_BaseTime), TARGET :: monthbdys(0:MONTHS_PER_YEAR) - TYPE(ESMF_BaseTime), TARGET :: monthbdysleap(0:MONTHS_PER_YEAR) - TYPE(ESMF_BaseTime), TARGET :: monthedys(0:MONTHS_PER_YEAR) - TYPE(ESMF_BaseTime), TARGET :: monthedysleap(0:MONTHS_PER_YEAR) - - -!------------------------------------------------------------------------------ -! ! ESMF_CalKind_Flag -! -! ! F90 "enum" type to match C++ ESMC_CalKind_Flag enum - - type ESMF_CalKind_Flag - integer :: caltype - end type - - type(ESMF_CalKind_Flag), parameter :: & - ESMF_CALKIND_GREGORIAN = ESMF_CalKind_Flag(1), & - ESMF_CALKIND_NOLEAP = ESMF_CalKind_Flag(2) - -! type(ESMF_CalKind_Flag), parameter :: & -! ESMF_CALKIND_GREGORIAN = ESMF_CalKind_Flag(1), & -! ESMF_CALKIND_JULIAN = ESMF_CalKind_Flag(2), & -! ! like Gregorian, except Feb always has 28 days -! ESMF_CALKIND_NOLEAP = ESMF_CalKind_Flag(3), & -! ! 12 months, 30 days each -! ESMF_CALKIND_360DAY = ESMF_CalKind_Flag(4), & -! ! user defined -! ESMF_CALKIND_GENERIC = ESMF_CalKind_Flag(5), & -! ! track base time seconds only -! ESMF_CALKIND_NOCALENDAR = ESMF_CalKind_Flag(6) - -!------------------------------------------------------------------------------ -! ! ESMF_Calendar -! -! ! F90 class type to match C++ Calendar class in size only; -! ! all dereferencing within class is performed by C++ implementation -! -!------------------------------------------------------------------------------ -! -! ! ESMF_DaysPerYear -! - type ESMF_DaysPerYear - integer :: D = 0 ! whole days per year - integer :: Dn = 0 ! fractional days per year numerator - integer :: Dd = 1 ! fractional days per year denominator - end type ! e.g. for Venus, D=0, Dn=926, Dd=1000 -! -!------------------------------------------------------------------------------ -! ! ESMF_Calendar -! -! - type ESMF_Calendar - type(ESMF_CalKind_Flag) :: Type - logical :: Set = .false. - integer, dimension(MONTHS_PER_YEAR) :: DaysPerMonth = 0 - integer :: SecondsPerDay = 0 - integer :: SecondsPerYear = 0 - type(ESMF_DaysPerYear) :: DaysPerYear - end type -!------------------------------------------------------------------------------ -! !PUBLIC DATA: added by Juanxiong He, in order to breakthe cycle call between -! ESMF_Stubs and ESMF_Time - TYPE(ESMF_Calendar), public, save, pointer :: defaultCal ! Default Calendar - TYPE(ESMF_Calendar), public, save, pointer :: gregorianCal ! gregorian Calendar - TYPE(ESMF_Calendar), public, save, pointer :: noleapCal ! noleap Calendar - -! -!------------------------------------------------------------------------------ -! !PUBLIC TYPES: - public initdaym -! public mday -! public mdayleap -! public monthbdys -! public monthbdysleap -! public monthedys -! public monthedysleap -! public daym -! public daymleap -! public mdaycum -! public mdayleapcum - public ndaysinmonth - public nsecondsinmonth - public ndaysinyear - public nsecondsinyear - public nmonthinyearsec - public ndayinyearsec - public nsecondsinyearmonth - public isleap - public ESMF_CalKind_Flag - public ESMF_CALKIND_GREGORIAN, ESMF_CALKIND_NOLEAP -! ESMF_CALKIND_360DAY, ESMF_CALKIND_NOCALENDAR -! public ESMF_CAL_JULIAN -! public ESMF_CAL_GENERIC - public ESMF_Calendar - public ESMF_DaysPerYear - -!------------------------------------------------------------------------------ -! -! !PUBLIC MEMBER FUNCTIONS: - public ESMF_CalendarCreate - -! Required inherited and overridden ESMF_Base class methods - - public ESMF_CalendarInitialized ! Only in this implementation, intended - ! to be private within ESMF methods -!EOPI - -!------------------------------------------------------------------------------ -! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - -!============================================================================== - - contains - - -!============================================================================== -!BOP -! !IROUTINE: ESMF_CalendarCreate - Create a new ESMF Calendar of built-in type - -! !INTERFACE: - ! Private name; call using ESMF_CalendarCreate() - function ESMF_CalendarCreate(name, calkindflag, rc) - -! !RETURN VALUE: - type(ESMF_Calendar) :: ESMF_CalendarCreate - -! !ARGUMENTS: - character (len=*), intent(in), optional :: name - type(ESMF_CalKind_Flag), intent(in) :: calkindflag - integer, intent(out), optional :: rc - -! !DESCRIPTION: -! Creates and sets a {\tt calendar} to the given built-in -! {\tt ESMF\_CalKind_Flag}. -! -! This is a private method; invoke via the public overloaded entry point -! {\tt ESMF\_CalendarCreate()}. -! -! The arguments are: -! \begin{description} -! \item[{[name]}] -! The name for the newly created calendar. If not specified, a -! default unique name will be generated: "CalendarNNN" where NNN -! is a unique sequence number from 001 to 999. -! \item[calkindflag] -! The built-in {\tt ESMF\_CalKind_Flag}. Valid values are: -! {\tt ESMF\_CAL\_360DAY}, {\tt ESMF\_CAL\_GREGORIAN}, -! {\tt ESMF\_CAL\_JULIANDAY}, {\tt ESMF\_CAL\_NOCALENDAR}, and -! {\tt ESMF\_CAL\_NOLEAP}. -! See the "Time Manager Reference" document for a description of -! each calendar type. -! \item[{[rc]}] -! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. -! \end{description} -! -!EOP -! !REQUIREMENTS: -! TMGn.n.n - type(ESMF_DaysPerYear) :: dayspy - - if ( present(rc) ) rc = ESMF_FAILURE -! Calendar is hard-coded. Use ESMF library if more flexibility is needed. -! write(6,*) 'tcx ESMF_CalendarCreate ',calkindflag%caltype, ESMF_CALKIND_NOLEAP%caltype, ESMF_CALKIND_GREGORIAN%caltype - if ( calkindflag%caltype == ESMF_CALKIND_NOLEAP%caltype ) then -! write(6,*) 'tcx ESMF_CalendarCreate: initialize noleap calendar ' - ESMF_CalendarCreate%Type = ESMF_CALKIND_NOLEAP - elseif ( calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype ) then -! write(6,*) 'tcx ESMF_CalendarCreate: initialize gregorian calendar ' - ESMF_CalendarCreate%Type = ESMF_CALKIND_GREGORIAN - else -! write(6,*) 'tcx ESMF_CalendarCreate: ERROR initialize invalid calendar' - call wrf_error_fatal( "Error:: ESMF_CalendarCreate invalid calendar") - endif - -!$$$ This is a bug on some systems -- need initial value set by compiler at -!$$$ startup. - ESMF_CalendarCreate%Set = .true. - ESMF_CalendarCreate%SecondsPerDay = SECONDS_PER_DAY -! DaysPerYear and SecondsPerYear are incorrect for Gregorian calendars... - dayspy%D = size(daym) - dayspy%Dn = 0 - dayspy%Dd = 1 - ESMF_CalendarCreate%DaysPerYear = dayspy - ESMF_CalendarCreate%SecondsPerYear = ESMF_CalendarCreate%SecondsPerDay & - * dayspy%D - ESMF_CalendarCreate%DaysPerMonth(:) = mday(:) - - if ( present(rc) ) rc = ESMF_SUCCESS - - end function ESMF_CalendarCreate - - -!============================================================================== -!BOP -! !IROUTINE: ESMF_CalendarInitialized - check if calendar was created - -! !INTERFACE: - function ESMF_CalendarInitialized(calendar) - -! !RETURN VALUE: - logical ESMF_CalendarInitialized - -! !ARGUMENTS: - type(ESMF_Calendar), intent(in) :: calendar - -! !DESCRIPTION: -!EOP -! !REQUIREMENTS: -! TMGn.n.n - ESMF_CalendarInitialized = calendar%set - if ( calendar%SecondsPerDay == 0 ) & - ESMF_CalendarInitialized = .false. - - end function ESMF_CalendarInitialized - -!============================================================================== - -SUBROUTINE initdaym - IMPLICIT NONE - INTEGER i,j,m - - m = 1 - mdaycum(0) = 0 -!$$$ push this down into ESMF_BaseTime constructor - monthbdys(0)%S = 0 - monthbdys(0)%Sn = 0 - monthbdys(0)%Sd = 0 - DO i = 1,MONTHS_PER_YEAR - DO j = 1,mday(i) - daym(m) = i - m = m + 1 - ENDDO - mdaycum(i) = mdaycum(i-1) + mday(i) -!$$$ push this down into ESMF_BaseTime constructor - monthbdys(i)%S = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 ) - monthbdys(i)%Sn = 0 - monthbdys(i)%Sd = 0 - ENDDO - ! End of month seconds, day before the beginning of next month - DO i = 0,MONTHS_PER_YEAR - j = i + 1 - if ( i == MONTHS_PER_YEAR ) j = 0 - monthedys(i) = monthbdys(j) - monthedys(i)%S = monthedys(i)%S - SECONDS_PER_DAY - ENDDO - - m = 1 - mdayleapcum(0) = 0 -!$$$ push this down into ESMF_BaseTime constructor - monthbdysleap(0)%S = 0 - monthbdysleap(0)%Sn = 0 - monthbdysleap(0)%Sd = 0 - DO i = 1,MONTHS_PER_YEAR - DO j = 1,mdayleap(i) - daymleap(m) = i - m = m + 1 - ENDDO - mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i) -!$$$ push this down into ESMF_BaseTime constructor - monthbdysleap(i)%S = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 ) - monthbdysleap(i)%Sn = 0 - monthbdysleap(i)%Sd = 0 - ENDDO - ! End of month seconds, day before the beginning of next month - DO i = 0,MONTHS_PER_YEAR - j = i + 1 - if ( i == MONTHS_PER_YEAR ) j = 0 - monthedysleap(i) = monthbdysleap(j) - monthedysleap(i)%S = monthedysleap(i)%S - SECONDS_PER_DAY - ENDDO - -END SUBROUTINE initdaym - -!============================================================================== - -integer(esmf_kind_i8) FUNCTION nsecondsinyear ( year, calkindflag ) - ! Compute the number of seconds in the given year - IMPLICIT NONE - INTEGER, INTENT(IN) :: year - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - - nsecondsinyear = SECONDS_PER_DAY * INT( ndaysinyear(year, calkindflag) , ESMF_KIND_I8 ) - -END FUNCTION nsecondsinyear - -!============================================================================== - -integer function ndaysinmonth( year,month,calkindflag) - ! Compute number of days in month for year, month, cal - IMPLICIT NONE - INTEGER, INTENT(in) :: year,month - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - ! locals - - IF ( ( MONTH < 1 ) .OR. ( MONTH > MONTHS_PER_YEAR ) ) THEN - CALL wrf_error_fatal( 'ERROR ndaysinmonth: MONTH out of range' ) - ENDIF - - IF ( isleap(year,calkindflag) ) THEN - ndaysinmonth = mdayleap(month) - ELSE - ndaysinmonth = mday(month) - ENDIF - -END function ndaysinmonth -!============================================================================== - -integer(esmf_kind_i8) function nsecondsinmonth( year,month,calkindflag) - ! Compute number of days in month for year, month, cal - IMPLICIT NONE - INTEGER, INTENT(in) :: year,month - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - ! locals - - nsecondsinmonth = ndaysinmonth(year,month,calkindflag)*SECONDS_PER_DAY - -END function nsecondsinmonth - -!============================================================================== - -integer function nmonthinyearsec(year,basetime,calkindflag) - ! Compute month for year, basetime, cal - IMPLICIT NONE - INTEGER, INTENT(in) :: year - type(ESMF_BaseTime), intent(in) :: basetime - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - ! locals - TYPE(ESMF_BaseTime), pointer :: MMbdys(:) - integer :: mm,i - - IF ( isleap(year,calkindflag) ) THEN - MMbdys => monthbdysleap - ELSE - MMbdys => monthbdys - ENDIF - MM = -1 - DO i = 1,MONTHS_PER_YEAR - IF ( ( basetime >= MMbdys(i-1) ) .AND. ( basetime < MMbdys(i) ) ) THEN - MM = i - EXIT - ENDIF - ENDDO - IF ( MM == -1 ) THEN - CALL wrf_error_fatal( 'nmonthinyearsec: could not extract month of year from time' ) - ENDIF - nmonthinyearsec = mm - -END function nmonthinyearsec - -!============================================================================== -integer function ndayinyearsec(year, basetime, calkindflag) - ! Compute day of year for year, basetime, cal - IMPLICIT NONE - INTEGER, INTENT(in) :: year - type(ESMF_BaseTime), intent(in) :: basetime - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - ! locals - TYPE(ESMF_BaseTime), pointer :: MMbdys(:) - TYPE(ESMF_BaseTime) :: tmpbasetime - integer :: mm - - mm = nmonthinyearsec(year, basetime, calkindflag) - - IF ( isleap(year,calkindflag) ) THEN - MMbdys => monthbdysleap - ELSE - MMbdys => monthbdys - ENDIF - tmpbasetime = basetime - MMbdys(mm-1) - ndayinyearsec = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1 - -end function ndayinyearsec -!============================================================================== -integer(esmf_kind_i8) function nsecondsinyearmonth(year, month, calkindflag) - ! Compute number of seconds from start of year for year, month, cal - IMPLICIT NONE - INTEGER, INTENT(in) :: year - INTEGER, INTENT(in) :: month - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - - ! locals - TYPE(ESMF_BaseTime), pointer :: MMbdys(:) - - IF ( ( MONTH < 1 ) .OR. ( MONTH > MONTHS_PER_YEAR ) ) THEN - CALL wrf_error_fatal( 'ERROR nsecondsinyearmonth(): MONTH out of range' ) - ENDIF - - IF ( isleap(year, calkindflag) ) THEN - MMbdys => monthbdysleap - ELSE - MMbdys => monthbdys - ENDIF - - nsecondsinyearmonth = MMbdys(month-1)%s - -end function nsecondsinyearmonth -!============================================================================== - -integer FUNCTION ndaysinyear ( year,calkindflag ) - ! Compute the number of days in the given year - IMPLICIT NONE - INTEGER, INTENT(IN) :: year - type(ESMF_CalKind_Flag),intent(in) :: calkindflag - - IF ( isleap( year,calkindflag ) ) THEN - ndaysinyear = 366 - ELSE - ndaysinyear = 365 - ENDIF -END FUNCTION ndaysinyear - -!============================================================================== - -logical FUNCTION isleap ( year, calkindflag ) - ! Compute the number of days in February for the given year - IMPLICIT NONE - INTEGER,intent(in) :: year - type(ESMF_CalKind_Flag) :: calkindflag - ! local - INTEGER :: lyear - - lyear = abs(year) ! make sure it handles negative years - - isleap = .false. ! By default, February has 28 days ... - - if (calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype) then - IF (MOD(lyear,4).eq.0) THEN - isleap = .true. ! But every four years, it has 29 days ... - IF (MOD(lyear,100).eq.0) THEN - isleap = .false. ! Except every 100 years, when it has 28 days ... - IF (MOD(lyear,400).eq.0) THEN - isleap = .true. ! Except every 400 years, when it has 29 days. - END IF - END IF - END IF - endif - -END FUNCTION isleap - -!============================================================================== -end module ESMF_CalendarMod diff --git a/src/esmf_wrf_timemgr/ESMF_ClockMod.F90 b/src/esmf_wrf_timemgr/ESMF_ClockMod.F90 deleted file mode 100644 index af7f3f2..0000000 --- a/src/esmf_wrf_timemgr/ESMF_ClockMod.F90 +++ /dev/null @@ -1,1247 +0,0 @@ -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF Clock Module -module ESMF_ClockMod - ! - !============================================================================== - ! - ! This file contains the Clock class definition and all Clock class methods. - ! - !------------------------------------------------------------------------------ - ! INCLUDES -#include - - !============================================================================== - !BOPI - ! !MODULE: ESMF_ClockMod - ! - ! !DESCRIPTION: - ! Part of Time Manager F90 API wrapper of C++ implemenation - ! - ! Defines F90 wrapper entry points for corresponding - ! C++ class {\tt ESMC\_Time} implementation - ! - ! See {\tt ../include/ESMC\_Clock.h} for complete description - ! - !------------------------------------------------------------------------------ - ! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! associated derived types - use ESMF_TimeIntervalMod ! , only : ESMF_TimeInterval - use ESMF_TimeMod ! , only : ESMF_Time - use ESMF_AlarmMod, only : ESMF_Alarm - - implicit none - ! - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_Clock - ! - ! ! F90 class type to match C++ Clock class in size only; - ! ! all dereferencing within class is performed by C++ implementation - - - ! internals for ESMF_Clock - type ESMF_ClockInt - type(ESMF_TimeInterval) :: TimeStep - type(ESMF_Time) :: StartTime - type(ESMF_Time) :: StopTime - type(ESMF_Time) :: RefTime - type(ESMF_Time) :: CurrTime - type(ESMF_Time) :: PrevTime - integer(ESMF_KIND_I8) :: AdvanceCount - integer :: ClockMutex - integer :: NumAlarms - ! Note: to mimic ESMF 2.1.0+, AlarmList is maintained - ! within ESMF_Clock even though copies of each alarm are - ! returned from ESMF_AlarmCreate() at the same time they - ! are copied into the AlarmList! This duplication is not - ! as hideous as it might be because the ESMF_Alarm type - ! has data members that are all POINTERs (thus the horrible - ! shallow-copy-masquerading-as-reference-copy hack works). - type(ESMF_Alarm), pointer, dimension(:) :: AlarmList => null() - end type ESMF_ClockInt - - ! Actual public type: this bit allows easy mimic of "deep" ESMF_ClockCreate - ! in ESMF 2.1.0+ - ! NOTE: DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE. It emulates ESMF - ! shallow-copy-masquerading-as-reference-copy. - type ESMF_Clock - type(ESMF_ClockInt), pointer :: clockint => null() - end type ESMF_Clock - - !------------------------------------------------------------------------------ - ! !PUBLIC TYPES: - public ESMF_Clock - public ESMF_ClockInt ! needed on AIX but not PGI - !------------------------------------------------------------------------------ - ! - ! !PUBLIC MEMBER FUNCTIONS: - public ESMF_ClockCreate - public ESMF_ClockDestroy - public ESMF_ClockSet - ! public ESMF_ClockSetOLD - public ESMF_ClockGet - ! public ESMF_ClockGetAdvanceCount - ! public ESMF_ClockGetTimeStep - ! public ESMF_ClockSetTimeStep - ! public ESMF_ClockGetCurrTime - ! public ESMF_ClockSetCurrTime - ! public ESMF_ClockGetStartTime - ! public ESMF_ClockGetStopTime - ! public ESMF_ClockGetRefTime - ! public ESMF_ClockGetPrevTime - ! public ESMF_ClockGetCurrSimTime - ! public ESMF_ClockGetPrevSimTime - ! This must be public for ESMF_AlarmClockMod... - public ESMF_ClockAddAlarm - public ESMF_ClockGetAlarmList - ! public ESMF_ClockGetNumAlarms - ! public ESMF_ClockSyncToWallClock - public ESMF_ClockAdvance - public ESMF_ClockIsStopTime - public ESMF_ClockStopTimeDisable - - ! Required inherited and overridden ESMF_Base class methods - - ! public ESMF_ClockRead - ! public ESMF_ClockWrite - public ESMF_ClockValidate - public ESMF_ClockPrint - !EOPI - - !------------------------------------------------------------------------------ - ! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - - !============================================================================== - -contains - - !============================================================================== - ! - ! This section includes the Set methods. - ! - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockSetOLD - Initialize a clockint - - ! !INTERFACE: - subroutine ESMF_ClockSetOLD(clockint, TimeStep, StartTime, & - StopTime, RefTime, rc) - - ! !ARGUMENTS: - type(ESMF_ClockInt), intent(out) :: clockint - type(ESMF_TimeInterval), intent(in), optional :: TimeStep - type(ESMF_Time), intent(in) :: StartTime - type(ESMF_Time), intent(in) :: StopTime - type(ESMF_Time), intent(in), optional :: RefTime - integer, intent(out), optional :: rc - ! Local - integer i - - ! !DESCRIPTION: - ! Initialize an {\tt ESMF\_Clock} - ! - ! The arguments are: - ! \begin{description} - ! \item[clockint] - ! The object instance to initialize - ! \item[{[TimeStep]}] - ! The {\tt ESMF\_Clock}'s time step interval - ! \item[StartTime] - ! The {\tt ESMF\_Clock}'s starting time - ! \item[StopTime] - ! The {\tt ESMF\_Clock}'s stopping time - ! \item[{[RefTime]}] - ! The {\tt ESMF\_Clock}'s reference time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.1, TMG3.4.4 - !EOP - IF ( PRESENT(TimeStep) ) clockint%TimeStep = TimeStep - IF ( PRESENT(RefTime) )THEN - clockint%RefTime = RefTime - ELSE - clockint%RefTime = StartTime - END IF - clockint%CurrTime = StartTime - clockint%StartTime = StartTime - clockint%StopTime = StopTime - clockint%NumAlarms = 0 - clockint%AdvanceCount = 0 - ALLOCATE(clockint%AlarmList(MAX_ALARMS)) - ! TBH: This incredible hack can be removed once ESMF_*Validate() - ! TBH: can tell if a deep ESMF_* was created or not. - DO i = 1, MAX_ALARMS - NULLIFY( clockint%AlarmList( i )%alarmint ) - ENDDO - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockSetOLD - - - ! !IROUTINE: ESMF_ClockSet - Set clock properties -- for compatibility with ESMF 2.0.1 - - ! !INTERFACE: - subroutine ESMF_ClockSet(clock, TimeStep, StartTime, StopTime, & - RefTime, CurrTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock - type(ESMF_TimeInterval), intent(in), optional :: TimeStep - type(ESMF_Time), intent(in), optional :: StartTime - type(ESMF_Time), intent(in), optional :: StopTime - type(ESMF_Time), intent(in), optional :: RefTime - type(ESMF_Time), intent(in), optional :: CurrTime - integer, intent(out), optional :: rc - ! Local - integer ierr - - ! !DESCRIPTION: - ! Initialize an {\tt ESMF\_Clock} - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to initialize - ! \item[{[TimeStep]}] - ! The {\tt ESMF\_Clock}'s time step interval - ! \item[StartTime] - ! The {\tt ESMF\_Clock}'s starting time - ! \item[StopTime] - ! The {\tt ESMF\_Clock}'s stopping time - ! \item[{[RefTime]}] - ! The {\tt ESMF\_Clock}'s reference time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.1, TMG3.4.4 - !EOP - ierr = ESMF_SUCCESS - IF ( PRESENT(TimeStep) ) THEN - CALL ESMF_ClockSetTimeStep ( clock, TimeStep, rc=ierr ) - ENDIF - IF ( PRESENT(RefTime) ) clock%clockint%RefTime = RefTime - IF ( PRESENT(StartTime) ) clock%clockint%StartTime = StartTime - IF ( PRESENT(StopTime) ) clock%clockint%StopTime = StopTime - IF ( PRESENT(CurrTime) ) THEN - CALL ESMF_ClockSetCurrTime(clock, CurrTime, rc=ierr) - ENDIF - IF ( PRESENT(rc) ) rc = ierr - - end subroutine ESMF_ClockSet - - - ! Create ESMF_Clock using ESMF 2.1.0+ semantics - FUNCTION ESMF_ClockCreate( name, TimeStep, StartTime, StopTime, & - RefTime, rc ) - ! return value - type(ESMF_Clock) :: ESMF_ClockCreate - ! !ARGUMENTS: - character (len=*), intent(in), optional :: name - type(ESMF_TimeInterval), intent(in), optional :: TimeStep - type(ESMF_Time), intent(in) :: StartTime - type(ESMF_Time), intent(in) :: StopTime - type(ESMF_Time), intent(in), optional :: RefTime - integer, intent(out), optional :: rc - ! locals - type(ESMF_Clock) :: clocktmp - ! TBH: ignore allocate errors, for now - ALLOCATE( clocktmp%clockint ) - CALL ESMF_ClockSetOLD( clocktmp%clockint, & - TimeStep= TimeStep, & - StartTime=StartTime, & - StopTime= StopTime, & - RefTime=RefTime, rc=rc ) - ESMF_ClockCreate = clocktmp - END FUNCTION ESMF_ClockCreate - - ! - ! Deallocate memory for ESMF_Clock - ! - SUBROUTINE ESMF_ClockDestroy( clock, rc ) - - TYPE(ESMF_Clock), INTENT(INOUT) :: clock - INTEGER, INTENT( OUT), OPTIONAL :: rc - - if (associated(clock%clockint)) then - if (associated(clock%clockint%AlarmList)) deallocate(clock%clockint%AlarmList) - deallocate(clock%clockint) - endif - - ! TBH: ignore deallocate errors, for now - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - - END SUBROUTINE ESMF_ClockDestroy - - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGet - Get clock properties -- for compatibility with ESMF 2.0.1 - - ! tcraig added alarmCount for ccsm4, consistent with ESMF3 interface - - ! !INTERFACE: - subroutine ESMF_ClockGet(clock, StartTime, CurrTime, & - AdvanceCount, StopTime, TimeStep, & - PrevTime, RefTime, AlarmCount, & - rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Time), intent(out), optional :: StartTime - type(ESMF_Time), intent(out), optional :: CurrTime - type(ESMF_Time), intent(out), optional :: StopTime - type(ESMF_Time), intent(out), optional :: PrevTime - type(ESMF_Time), intent(out), optional :: RefTime - integer(ESMF_KIND_I8), intent(out), optional :: AdvanceCount - integer, intent(out), optional :: AlarmCount - type(ESMF_TimeInterval), intent(out), optional :: TimeStep - integer, intent(out), optional :: rc - integer :: ierr - - ! !DESCRIPTION: - ! Returns the number of times the {\tt ESMF\_Clock} has been advanced - ! (time stepped) - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the advance count from - ! \item[StartTime] - ! The start time - ! \item[CurrTime] - ! The current time - ! \item[AdvanceCount] - ! The number of times the {\tt ESMF\_Clock} has been advanced - ! \item[StopTime] - ! The {\tt ESMF\_Clock}'s stopping time - ! \item[{[TimeStep]}] - ! The {\tt ESMF\_Clock}'s time step interval - ! \item[{[PrevTime]}] - ! The {\tt ESMF\_Clock}'s previous current time - ! \item[{[PrevTime]}] - ! The {\tt ESMF\_Clock}'s reference time - ! \item[{[AlarmCount]}] - ! The {\tt ESMF\_Clock}'s number of valid alarms - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG3.5.1 - !EOP - ierr = ESMF_SUCCESS - - IF ( PRESENT (StartTime) ) THEN - CALL ESMF_ClockGetStartTime( clock, StartTime=StartTime, rc=ierr ) - ENDIF - IF ( PRESENT (CurrTime) ) THEN - CALL ESMF_ClockGetCurrTime( clock , CurrTime, ierr ) - ENDIF - IF ( PRESENT (StopTime) ) THEN - CALL ESMF_ClockGetStopTime( clock , StopTime, ierr ) - ENDIF - IF ( PRESENT (AdvanceCount) ) THEN - CALL ESMF_ClockGetAdvanceCount(clock, AdvanceCount, ierr) - ENDIF - IF ( PRESENT (TimeStep) ) THEN - CALL ESMF_ClockGetTimeStep(clock, TimeStep, ierr) - ENDIF - IF ( PRESENT (PrevTime) ) THEN - CALL ESMF_ClockGetPrevTime(clock, PrevTime, ierr) - ENDIF - IF ( PRESENT (RefTime) ) THEN - CALL ESMF_ClockGetRefTime(clock, RefTime, ierr) - ENDIF - IF ( PRESENT (AlarmCount) ) THEN - CALL ESMF_ClockGetNumAlarms(clock, AlarmCount, ierr) - ENDIF - - IF ( PRESENT (rc) ) THEN - rc = ierr - ENDIF - - end subroutine ESMF_ClockGet - - - ! !IROUTINE: ESMF_ClockGetAdvanceCount - Get the clock's advance count - - ! !INTERFACE: - subroutine ESMF_ClockGetAdvanceCount(clock, AdvanceCount, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - integer(ESMF_KIND_I8), intent(out) :: AdvanceCount - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Returns the number of times the {\tt ESMF\_Clock} has been advanced - ! (time stepped) - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the advance count from - ! \item[AdvanceCount] - ! The number of times the {\tt ESMF\_Clock} has been advanced - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG3.5.1 - !EOP - - AdvanceCount = clock%clockint%AdvanceCount - - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockGetAdvanceCount - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetTimeStep - Get a clock's timestep interval - - ! !INTERFACE: - subroutine ESMF_ClockGetTimeStep(clock, TimeStep, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_TimeInterval), intent(out) :: TimeStep - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s timestep interval - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the time step from - ! \item[TimeStep] - ! The time step - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.2 - !EOP - - TimeStep = clock%clockint%TimeStep - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockGetTimeStep - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockSetTimeStep - Set a clock's timestep interval - - ! !INTERFACE: - subroutine ESMF_ClockSetTimeStep(clock, TimeStep, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock - type(ESMF_TimeInterval), intent(in) :: TimeStep - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Clock}'s timestep interval - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to set the time step - ! \item[TimeStep] - ! The time step - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.4.2 - !EOP - - clock%clockint%TimeStep = TimeStep - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockSetTimeStep - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetCurrTime - Get a clock's current time - - ! !INTERFACE: - subroutine ESMF_ClockGetCurrTime(clock, CurrTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Time), intent(out) :: CurrTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s current time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the current time from - ! \item[CurrTime] - ! The current time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.4 - !EOP - - CurrTime = clock%clockint%CurrTime - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - end subroutine ESMF_ClockGetCurrTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockSetCurrTime - Set a clock's current time - - ! !INTERFACE: - subroutine ESMF_ClockSetCurrTime(clock, CurrTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock - type(ESMF_Time), intent(in) :: CurrTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Clock}'s current time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to set the current time from - ! \item[CurrTime] - ! The current time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.4.3 - !EOP - - clock%clockint%CurrTime = CurrTime - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockSetCurrTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetStartTime - Get a clock's start time - - ! !INTERFACE: - subroutine ESMF_ClockGetStartTime(clock, StartTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Time), intent(out) :: StartTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s start time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the start time from - ! \item[StartTime] - ! The start time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.3 - !EOP - - StartTime = clock%clockint%StartTime - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockGetStartTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetStopTime - Get a clock's stop time - - ! !INTERFACE: - subroutine ESMF_ClockGetStopTime(clock, StopTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Time), intent(out) :: StopTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s stop time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the stop time from - ! \item[StopTime] - ! The stop time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.3 - !EOP - - StopTime = clock%clockint%StopTime - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockGetStopTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetRefTime - Get a clock's reference time - - ! !INTERFACE: - subroutine ESMF_ClockGetRefTime(clock, RefTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Time), intent(out) :: RefTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s reference time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the reference time from - ! \item[RefTime] - ! The reference time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.3 - !EOP - refTime = clock%clockint%RefTime - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - end subroutine ESMF_ClockGetRefTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetPrevTime - Get a clock's previous current time - - ! !INTERFACE: - subroutine ESMF_ClockGetPrevTime(clock, PrevTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Time), intent(out) :: PrevTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s previous current time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the previous current time from - ! \item[PrevTime] - ! The previous current time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.4 - !EOP - - prevTime = Clock%clockint%CurrTime - Clock%clockint%TimeStep - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - end subroutine ESMF_ClockGetPrevTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetCurrSimTime - Get a clock's current simulation time - - ! !INTERFACE: - subroutine ESMF_ClockGetCurrSimTime(clock, CurrSimTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_TimeInterval), intent(out) :: CurrSimTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s current simulation time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the current simulation time from - ! \item[CurrSimTime] - ! The current simulation time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.5 - !EOP - CALL wrf_error_fatal( 'ESMF_ClockGetCurrSimTime not supported' ) - end subroutine ESMF_ClockGetCurrSimTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetPrevSimTime - Get a clock's previous simulation time - - ! !INTERFACE: - subroutine ESMF_ClockGetPrevSimTime(clock, PrevSimTime, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_TimeInterval), intent(out) :: PrevSimTime - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s previous simulation time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the previous simulation time from - ! \item[PrevSimTime] - ! The previous simulation time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.5.5 - !EOP - CALL wrf_error_fatal( 'ESMF_ClockGetPrevSimTime not supported' ) - end subroutine ESMF_ClockGetPrevSimTime - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockAddAlarm - Add an alarm to a clock's alarm list - - ! !INTERFACE: - subroutine ESMF_ClockAddAlarm(clock, Alarm, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock - type(ESMF_Alarm), intent(inout) :: Alarm - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Add an {\tt ESMF\_Alarm} to an {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to add an {\tt ESMF\_Alarm} to - ! \item[Alarm] - ! The {\tt ESMF\_Alarm} to add to the {\tt ESMF\_Clock}'s - ! {\tt ESMF\_Alarm} list - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.1, TMG4.2 - !EOP - - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - clock%clockint%NumAlarms = clock%clockint%NumAlarms + 1 - IF ( clock%clockint%NumAlarms > SIZE (clock%clockint%AlarmList) ) THEN - CALL wrf_error_fatal ( 'ESMF_ClockAddAlarm: too many alarms' ) - ELSE IF ( .NOT. ASSOCIATED( Alarm%alarmint ) ) THEN - CALL wrf_error_fatal ( & - 'ESMF_ClockAddAlarm: alarm not created' ) - ELSE - !TBH: why do all this initialization here? - IF ( Alarm%alarmint%RingTimeSet ) THEN - Alarm%alarmint%PrevRingTime = Alarm%alarmint%RingTime - & - Alarm%alarmint%RingInterval - ELSE - Alarm%alarmint%PrevRingTime = clock%clockint%CurrTime - ENDIF - Alarm%alarmint%Ringing = .FALSE. - - ! finally, load the alarm into the list - clock%clockint%AlarmList(clock%clockint%NumAlarms) = Alarm - ENDIF - - end subroutine ESMF_ClockAddAlarm - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetAlarmList - Get a clock's alarm list - - ! !INTERFACE: - subroutine ESMF_ClockGetAlarmList(clock, AlarmList, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_Alarm), pointer :: AlarmList(:) - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get an {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the {\tt ESMF\_Alarm} list from - ! \item[AlarmList] - ! The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.3 - !EOP - - AlarmList => clock%clockint%AlarmList - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockGetAlarmList - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockGetNumAlarms - Get the number of alarms in a clock's alarm list - - ! !INTERFACE: - subroutine ESMF_ClockGetNumAlarms(clock, NumAlarms, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - integer, intent(out) :: NumAlarms - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Get the number of {\tt ESMF\_Alarm}s in an {\tt ESMF\_Clock}'s - ! {\tt ESMF\_Alarm} list - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to get the number of {\tt ESMF\_Alarm}s from - ! \item[NumAlarms] - ! The number of {\tt ESMF\_Alarm}s in the {\tt ESMF\_Clock}'s - ! {\tt ESMF\_Alarm} list - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG4.3 - !EOP - - NumAlarms = clock%clockint%NumAlarms - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockGetNumAlarms - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockSyncToWallClock - Set clock's current time to wall clock time - - ! !INTERFACE: - subroutine ESMF_ClockSyncToWallClock(clock, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Set an {\tt ESMF\_Clock}'s current time to wall clock time - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to synchronize to wall clock time - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.4.5 - !EOP - CALL wrf_error_fatal( 'ESMF_ClockSyncToWallClock not supported' ) - end subroutine ESMF_ClockSyncToWallClock - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockAdvance - Advance a clock's current time by one time step - - ! !INTERFACE: - subroutine ESMF_ClockAdvance(clock, RingingAlarmList, & - NumRingingAlarms, rc) - - use ESMF_TimeMod - - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock - type(ESMF_Alarm), dimension(MAX_ALARMS), intent(out), optional :: & - RingingAlarmList - integer, intent(out), optional :: NumRingingAlarms - integer, intent(out), optional :: rc - ! Local - logical pred1, pred2, pred3 - integer i, n - type(ESMF_Alarm) :: alarm - ! - ! !DESCRIPTION: - ! Advance an {\tt ESMF\_Clock}'s current time by one time step - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to advance - ! \item[{[RingingAlarmList]}] - ! Return a list of any ringing alarms after the time step - ! \item[{[NumRingingAlarms]}] - ! The number of ringing alarms returned - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG3.4.1 - !EOP - clock%clockint%CurrTime = clock%clockint%CurrTime + & - clock%clockint%TimeStep - - IF ( Present(NumRingingAlarms) ) NumRingingAlarms = 0 - clock%clockint%AdvanceCount = clock%clockint%AdvanceCount + 1 - DO i = 1, MAX_ALARMS - alarm = clock%clockint%AlarmList(i) - ! TBH: This is really dangerous. We need to be able to NULLIFY - ! TBH: alarmint at compile-time (F95 synax) to make this safe. - !$$$TBH: see if F95 compile-time pointer-nullification is supported by all - !$$$TBH: compilers we support - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - IF ( alarm%alarmint%Enabled ) THEN - IF ( alarm%alarmint%RingIntervalSet ) THEN - pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE. - IF ( alarm%alarmint%StopTimeSet ) THEN - PRED1 = clock%clockint%CurrTime > alarm%alarmint%StopTime - ENDIF - IF ( alarm%alarmint%RingTimeSet ) THEN - PRED2 = ( alarm%alarmint%RingTime <= clock%clockint%CurrTime & - .AND. clock%clockint%CurrTime < alarm%alarmint%RingTime + & - clock%clockint%TimeStep ) - ENDIF - IF ( alarm%alarmint%RingIntervalSet ) THEN - PRED3 = ( alarm%alarmint%PrevRingTime + alarm%alarmint%RingInterval <= & - clock%clockint%CurrTime ) - ENDIF - IF ( ( .NOT. ( pred1 ) ) .AND. & - ( ( pred2 ) .OR. ( pred3 ) ) ) THEN - alarm%alarmint%Ringing = .TRUE. - IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime + & - alarm%alarmint%RingInterval - IF ( PRESENT( RingingAlarmList ) .AND. & - PRESENT ( NumRingingAlarms ) ) THEN - NumRingingAlarms = NumRingingAlarms + 1 - RingingAlarmList( NumRingingAlarms ) = alarm - ENDIF - ENDIF - ELSE IF ( alarm%alarmint%RingTimeSet ) THEN - IF ( alarm%alarmint%RingTime <= clock%clockint%CurrTime ) THEN - alarm%alarmint%Ringing = .TRUE. - IF ( PRESENT( RingingAlarmList ) .AND. & - PRESENT ( NumRingingAlarms ) ) THEN - NumRingingAlarms = NumRingingAlarms + 1 - RingingAlarmList( NumRingingAlarms ) = alarm - ENDIF - ENDIF - ENDIF - IF ( alarm%alarmint%StopTimeSet ) THEN - ENDIF - ENDIF - ENDIF - clock%clockint%AlarmList(i) = alarm - ENDDO - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - - end subroutine ESMF_ClockAdvance - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockStopTimeDisable - NOOP for compatibility with ESMF 2.1.0+ - - ! !INTERFACE: - subroutine ESMF_ClockStopTimeDisable(clock, rc) - ! - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - integer, intent(out), optional :: rc - - rc = ESMF_SUCCESS - - end subroutine ESMF_ClockStopTimeDisable - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockIsStopTime - Has the clock reached its stop time ? - - ! !INTERFACE: - function ESMF_ClockIsStopTime(clock, rc) - ! - ! !RETURN VALUE: - logical :: ESMF_ClockIsStopTime - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Return true if {\tt ESMF\_Clock} has reached its stop time, false - ! otherwise - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to check - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - - ! !REQUIREMENTS: - ! TMG3.5.6 - !EOP - - if ( clock%clockint%CurrTime .GE. clock%clockint%StopTime ) THEN - ESMF_ClockIsStopTime = .TRUE. - else - ESMF_ClockIsStopTime = .FALSE. - endif - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - - end function ESMF_ClockIsStopTime - - !------------------------------------------------------------------------------ - ! - ! This section defines the overridden Read, Write, Validate and Print methods - ! from the ESMF_Base class - ! - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockRead - Restores a clock - - ! !INTERFACE: - subroutine ESMF_ClockRead(clock, TimeStep, StartTime, StopTime, & - RefTime, CurrTime, PrevTime, AdvanceCount, & - AlarmList, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(out) :: clock - type(ESMF_TimeInterval), intent(in) :: TimeStep - type(ESMF_Time), intent(in) :: StartTime - type(ESMF_Time), intent(in) :: StopTime - type(ESMF_Time), intent(in) :: RefTime - type(ESMF_Time), intent(in) :: CurrTime - type(ESMF_Time), intent(in) :: PrevTime - integer(ESMF_KIND_I8), intent(in) :: AdvanceCount - type(ESMF_Alarm), dimension(MAX_ALARMS), intent(in) :: AlarmList - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Restore an {\tt ESMF\_Clock} - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to restore - ! \item[TimeStep] - ! The {\tt ESMF\_Clock}'s time step interval - ! \item[StartTime] - ! The {\tt ESMF\_Clock}'s starting time - ! \item[StopTime] - ! The {\tt ESMF\_Clock}'s stopping time - ! \item[RefTime] - ! The {\tt ESMF\_Clock}'s reference time - ! \item[CurrTime] - ! The {\tt ESMF\_Clock}'s current time - ! \item[PrevTime] - ! The {\tt ESMF\_Clock}'s previous time - ! \item[AdvanceCount] - ! The number of times the {\tt ESMF\_Clock} has been advanced - ! \item[AlarmList] - ! The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - !EOP - CALL wrf_error_fatal( 'ESMF_ClockRead not supported' ) - end subroutine ESMF_ClockRead - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockWrite - Saves a clock - - ! !INTERFACE: - subroutine ESMF_ClockWrite(clock, TimeStep, StartTime, StopTime, & - RefTime, CurrTime, PrevTime, AdvanceCount, & - AlarmList, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - type(ESMF_TimeInterval), intent(out) :: TimeStep - type(ESMF_Time), intent(out) :: StartTime - type(ESMF_Time), intent(out) :: StopTime - type(ESMF_Time), intent(out) :: RefTime - type(ESMF_Time), intent(out) :: CurrTime - type(ESMF_Time), intent(out) :: PrevTime - integer(ESMF_KIND_I8), intent(out) :: AdvanceCount - type(ESMF_Alarm), dimension(MAX_ALARMS), intent(out) :: AlarmList - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Save an {\tt ESMF\_Clock} - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! The object instance to save - ! \item[TimeStep] - ! The {\tt ESMF\_Clock}'s time step interval - ! \item[StartTime] - ! The {\tt ESMF\_Clock}'s starting time - ! \item[StopTime] - ! The {\tt ESMF\_Clock}'s stopping time - ! \item[RefTime] - ! The {\tt ESMF\_Clock}'s reference time - ! \item[CurrTime] - ! The {\tt ESMF\_Clock}'s current time - ! \item[PrevTime] - ! The {\tt ESMF\_Clock}'s previous time - ! \item[AdvanceCount] - ! The number of times the {\tt ESMF\_Clock} has been advanced - ! \item[AlarmList] - ! The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - !EOP - CALL wrf_error_fatal( 'ESMF_ClockWrite not supported' ) - end subroutine ESMF_ClockWrite - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockValidate - Validate a Clock's properties - - ! !INTERFACE: - subroutine ESMF_ClockValidate(clock, opts, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - character (len=*), intent(in), optional :: opts - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! Perform a validation check on an {\tt ESMF\_Clock}'s properties - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! {\tt ESMF\_Clock} to validate - ! \item[{[opts]}] - ! Validate options - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - CALL wrf_error_fatal( 'ESMF_ClockValidate not supported' ) - end subroutine ESMF_ClockValidate - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_ClockPrint - Print out a Clock's properties - - ! !INTERFACE: - subroutine ESMF_ClockPrint(clock, opts, rc) - - ! !ARGUMENTS: - type(ESMF_Clock), intent(in) :: clock - character (len=*), intent(in), optional :: opts - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! To support testing/debugging, print out an {\tt ESMF\_Clock}'s - ! properties. - ! - ! The arguments are: - ! \begin{description} - ! \item[clock] - ! {\tt ESMF\_Clock} to print out - ! \item[{[opts]}] - ! Print options - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - type(ESMF_Time) :: start_time - type(ESMF_Time) :: stop_time - type(ESMF_Time) :: curr_time - type(ESMF_Time) :: ref_time - type(ESMF_TimeInterval) :: timestep - - call ESMF_ClockGet( clock, startTime=start_time, & - stoptime=stop_time, currTime=curr_time, & - refTime=ref_time, timeStep=timestep, rc=rc ) - print *, 'Start time: ' - call ESMF_TimePrint( start_time ) - print *, 'Stop time: ' - call ESMF_TimePrint( stop_time ) - print *, 'Reference time: ' - call ESMF_TimePrint( ref_time ) - print *, 'Current time: ' - call ESMF_TimePrint( curr_time ) - print *, 'Time step: ' - call ESMF_TimeIntervalPrint( timestep) - end subroutine ESMF_ClockPrint - - !------------------------------------------------------------------------------ - -end module ESMF_ClockMod diff --git a/src/esmf_wrf_timemgr/ESMF_FractionMod.F90 b/src/esmf_wrf_timemgr/ESMF_FractionMod.F90 deleted file mode 100644 index 3442e31..0000000 --- a/src/esmf_wrf_timemgr/ESMF_FractionMod.F90 +++ /dev/null @@ -1,83 +0,0 @@ -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -! ESMF Fraction Module -! -!============================================================================== -! -! ESMF Fraction Module -module ESMF_FractionMod - ! - !============================================================================== - ! - ! This file contains the Fraction class definition and all Fraction - ! class methods. - ! - !------------------------------------------------------------------------------ - ! INCLUDES - ! - !=============================================================================== - !BOPI - ! - ! !MODULE: ESMF_FractionMod - ! - ! !DESCRIPTION: - ! Part of ESMF F90 API wrapper of C++ implemenation - ! - ! Defines F90 wrapper entry points for corresponding - ! C++ implementaion of class {\tt ESMC\_Fraction} - ! - ! See {\tt ../include/ESMC\_Fraction.h} for complete description - ! - !------------------------------------------------------------------------------ - ! !USES: - - implicit none - ! - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_Fraction - ! - type ESMF_Fraction - private - integer :: n ! Integer fraction (exact) n/d; numerator - integer :: d ! Integer fraction (exact) n/d; denominator - end type ESMF_Fraction - ! - !------------------------------------------------------------------------------ - ! !PUBLIC TYPES: - public ESMF_Fraction - !------------------------------------------------------------------------------ - ! - ! !PUBLIC MEMBER FUNCTIONS: - - ! !PRIVATE MEMBER FUNCTIONS: - - !EOPI - - !------------------------------------------------------------------------------ - ! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - - !============================================================================== - - ! contains - - !============================================================================== - ! - ! Wrappers to C++ fraction routines - ! - !------------------------------------------------------------------------------ - ! - - !------------------------------------------------------------------------------ - -end module ESMF_FractionMod diff --git a/src/esmf_wrf_timemgr/ESMF_Macros.inc b/src/esmf_wrf_timemgr/ESMF_Macros.inc deleted file mode 100644 index d3da7ea..0000000 --- a/src/esmf_wrf_timemgr/ESMF_Macros.inc +++ /dev/null @@ -1,36 +0,0 @@ -#if 0 -$Id$ - -Earth System Modeling Framework -Copyright 2002-2003, University Corporation for Atmospheric Research, -Massachusetts Institute of Technology, Geophysical Fluid Dynamics -Laboratory, University of Michigan, National Centers for Environmental -Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -NASA Goddard Space Flight Center. -Licensed under the GPL. - -Do not have C++ or F90 style comments in here because this file is processed -by both C++ and F90 compilers. - -These lines prevent this file from being read more than once if it -ends up being included multiple times. -#endif - -#ifndef ESMF_MACROS_INC -#define ESMF_MACROS_INC - -#if 0 - -former file contents moved to ESMF_BaseMod -so user code can be compiled without requiring -the preprocessor. - -#endif - -#if 0 -i left the following macro here in case it is needed for our internal use. -#endif - -#define ESMF_SRCLINE __FILE__, __LINE__ - -#endif diff --git a/src/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 b/src/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 deleted file mode 100644 index 5467bdf..0000000 --- a/src/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 +++ /dev/null @@ -1,45 +0,0 @@ -module ESMF_ShrTimeMod - ! - !============================================================================== - ! - ! This file contains types and methods that are shared in the hierarchy - ! - !------------------------------------------------------------------------------ - ! INCLUDES - - !============================================================================== - !BOPI - ! !MODULE: ESMF_ShrTimeMod - ! - ! !DESCRIPTION: - ! - !------------------------------------------------------------------------------ - ! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! inherit from base time class - use ESMF_BaseTimeMod - use ESMF_CalendarMod - - implicit none - ! - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_Time - ! - ! ! F90 class type to match C++ Time class in size only; - ! ! all dereferencing within class is performed by C++ implementation - - type ESMF_Time - type(ESMF_BaseTime) :: basetime ! inherit base class - ! time instant is expressed as year + basetime - integer :: YR - type(ESMF_Calendar), pointer :: calendar => null() ! associated calendar - end type ESMF_Time - - public ESMF_Time - !============================================================================== -end module ESMF_ShrTimeMod diff --git a/src/esmf_wrf_timemgr/ESMF_Stubs.F90 b/src/esmf_wrf_timemgr/ESMF_Stubs.F90 deleted file mode 100644 index 082bbc2..0000000 --- a/src/esmf_wrf_timemgr/ESMF_Stubs.F90 +++ /dev/null @@ -1,167 +0,0 @@ -! Various dummy type definitions and routines for the sole purpose of -! mimicking newer ESMF interface features without necessarily implementing -! them. - -MODULE ESMF_Stubs - - IMPLICIT NONE - - PRIVATE - -! Bogus typedefs - TYPE ESMF_Grid - INTEGER :: dummy - END TYPE ESMF_Grid - - TYPE ESMF_GridComp - INTEGER :: dummy - END TYPE ESMF_GridComp - - TYPE ESMF_State - INTEGER :: dummy - END TYPE ESMF_State - - TYPE ESMF_VM - INTEGER :: dummy - END TYPE ESMF_VM - - TYPE ESMF_END_FLAG - INTEGER :: dummy - END TYPE ESMF_END_FLAG - TYPE(ESMF_END_FLAG), PARAMETER :: & - ESMF_END_ABORT = ESMF_END_FLAG(1), & - ESMF_END_NORMAL = ESMF_END_FLAG(2), & - ESMF_END_KEEPMPI = ESMF_END_FLAG(3) - - TYPE ESMF_MsgType - INTEGER :: mtype - END TYPE ESMF_MsgType - TYPE(ESMF_MsgType), PARAMETER :: & - ESMF_LOG_INFO = ESMF_MsgType(1), & - ESMF_LOG_WARNING = ESMF_MsgType(2), & - ESMF_LOG_ERROR = ESMF_MsgType(3) - - TYPE ESMF_LOG - INTEGER :: dummy - END TYPE ESMF_LOG - - TYPE ESMF_LogKind_Flag - INTEGER :: dummy - END TYPE ESMF_LogKind_Flag - TYPE(ESMF_LogKind_Flag), PARAMETER :: & - ESMF_LOGKIND_NONE = ESMF_LogKind_Flag(1), & - ESMF_LOGKIND_SINGLE = ESMF_LogKind_Flag(2), & - ESMF_LOGKIND_MULTI = ESMF_LogKind_Flag(3), & - ESMF_LOGKIND_MULTI_ON_ERROR = ESMF_LogKind_Flag(4) - - LOGICAL, private, save :: initialized = .false. - - PUBLIC ESMF_Grid, ESMF_GridComp, ESMF_State, ESMF_VM - PUBLIC ESMF_Initialize, ESMF_Finalize, ESMF_IsInitialized - PUBLIC ESMF_LogWrite, ESMF_LOG, ESMF_MsgType, ESMF_END_FLAG - PUBLIC ESMF_LOG_INFO, ESMF_LOG_WARNING, ESMF_LOG_ERROR - PUBLIC ESMF_END_ABORT, ESMF_END_NORMAL, ESMF_END_KEEPMPI - PUBLIC ESMF_LogKind_Flag - PUBLIC ESMF_LOGKIND_NONE, ESMF_LOGKIND_SINGLE, ESMF_LOGKIND_MULTI - PUBLIC ESMF_LOGKIND_MULTI_ON_ERROR - -CONTAINS - - -! NOOP - SUBROUTINE ESMF_Initialize( vm, defaultCalendar, logkindflag, rc ) - USE ESMF_BaseMod - USE ESMF_CalendarMod -! USE ESMF_TimeMod, only: defaultCal - TYPE(ESMF_VM), INTENT(IN ), OPTIONAL :: vm - TYPE(ESMF_CalKind_Flag), INTENT(IN ), OPTIONAL :: defaultCalendar - TYPE(ESMF_LogKind_Flag), INTENT(IN ), OPTIONAL :: logkindflag - INTEGER, INTENT( OUT), OPTIONAL :: rc - - TYPE(ESMF_CalKind_Flag) :: defaultCalType - INTEGER :: status - - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ! Initialize the default time manager calendar - IF ( PRESENT(defaultCalendar) )THEN - defaultCalType = defaultCalendar - ELSE - defaultCalType = ESMF_CALKIND_NOLEAP - END IF - allocate( defaultCal ) -! write(6,*) 'tcx1 ESMF_Stubs defcal ',defaultcaltype%caltype -! call flush(6) - defaultCal = ESMF_CalendarCreate( calkindflag=defaultCalType, & - rc=status) -! write(6,*) 'tcx2 ESMF_Stubs defcal ',defaultcal%type%caltype -! call flush(6) - allocate( gregorianCal ) -! write(6,*) 'tcx1 ESMF_Stubs grcal ',esmf_calkind_gregorian%caltype -! call flush(6) - gregorianCal = ESMF_CalendarCreate( calkindflag=ESMF_CALKIND_GREGORIAN, & - rc=status) -! write(6,*) 'tcx2 ESMF_Stubs grcal ',gregoriancal%type%caltype -! call flush(6) - allocate( noleapCal ) -! write(6,*) 'tcx1 ESMF_Stubs nlcal ',esmf_calkind_noleap%caltype -! call flush(6) - noleapCal = ESMF_CalendarCreate( calkindflag=ESMF_CALKIND_NOLEAP, & - rc=status) -! write(6,*) 'tcx2 ESMF_Stubs nlcal ',noleapcal%type%caltype -! call flush(6) - - ! initialize tables in time manager - CALL initdaym - - IF (status .ne. ESMF_SUCCESS) THEN - PRINT *, "Error initializing the default time manager calendar" - RETURN - END IF - initialized = .true. - - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - END SUBROUTINE ESMF_Initialize - - - FUNCTION ESMF_IsInitialized() - LOGICAL ESMF_IsInitialized - ESMF_IsInitialized = initialized - END FUNCTION ESMF_IsInitialized - - -! NOOP - SUBROUTINE ESMF_Finalize( endflag, rc ) - USE ESMF_BaseMod - type(ESMF_END_FLAG), intent(in), optional :: endflag - INTEGER, INTENT( OUT), OPTIONAL :: rc -#ifndef HIDE_MPI -#include -#endif - INTEGER :: ier - - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS -#ifndef HIDE_MPI - CALL MPI_Finalize( ier ) - IF ( ier .ne. mpi_success )THEN - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - END IF -#endif - END SUBROUTINE ESMF_Finalize - -! NOOP - SUBROUTINE ESMF_LogWrite( msg, MsgType, line, file, method, log, rc ) - USE ESMF_BaseMod - CHARACTER(LEN=*), INTENT(IN) :: msg - TYPE(ESMF_MsgType), INTENT(IN) :: msgtype - INTEGER, INTENT(IN), OPTIONAL :: line - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: method - TYPE(ESMF_LOG),TARGET,OPTIONAL :: log - INTEGER, INTENT(OUT),OPTIONAL :: rc - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - END SUBROUTINE ESMF_LogWrite - - -END MODULE ESMF_Stubs - - diff --git a/src/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 b/src/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 deleted file mode 100644 index 9147996..0000000 --- a/src/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 +++ /dev/null @@ -1,1739 +0,0 @@ -! $Id$ -! -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF TimeInterval Module - -module ESMF_TimeIntervalMod - - ! - !============================================================================== - ! - ! This file contains the TimeInterval class definition and all TimeInterval - ! class methods. - ! - !------------------------------------------------------------------------------ - ! INCLUDES -#include - ! - !=============================================================================== - !BOPI - ! !MODULE: ESMF_TimeIntervalMod - ! - ! !DESCRIPTION: - ! Part of Time Manager F90 API wrapper of C++ implemenation - ! - ! Defines F90 wrapper entry points for corresponding - ! C++ implementaion of class {\tt ESMC\_TimeInterval} - ! - ! See {\tt ../include/ESMC\_TimeInterval.h} for complete description - ! - !------------------------------------------------------------------------------ - ! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! inherit from base time class - use ESMF_BaseTimeMod - - ! associated derived types - use ESMF_FractionMod, only : ESMF_Fraction - use ESMF_CalendarMod - use ESMF_ShrTimeMod, only : ESMF_Time - - implicit none - ! - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_TimeInterval - ! - ! ! F90 class type to match C++ TimeInterval class in size only; - ! ! all dereferencing within class is performed by C++ implementation - - type ESMF_TimeInterval - ! time interval is expressed as basetime - type(ESMF_BaseTime) :: basetime ! inherit base class - ! Relative year and month fields support monthly or yearly time - ! intervals. Many operations are undefined when these fields are - ! non-zero! - INTEGER :: YR ! relative year - INTEGER :: MM ! relative month - logical :: starttime_set ! reference time set - type(ESMF_Time) :: starttime ! reference time - end type ESMF_TimeInterval - - !------------------------------------------------------------------------------ - ! !PUBLIC TYPES: - public ESMF_TimeInterval - !------------------------------------------------------------------------------ - ! - ! for running WRF, add three subroutines or functions (WRFADDITION_TimeIntervalGet, - ! ESMF_TimeIntervalDIVQuot, ESMF_TimeIntervalIsPositive), by jhe - ! !PUBLIC MEMBER FUNCTIONS: - public ESMF_TimeIntervalGet - public ESMF_TimeIntervalSet - public ESMF_TimeIntervalAbsValue - public ESMF_TimeIntervalNegAbsValue - public ESMF_TimeIntervalPrint - public normalize_timeint - - ! Required inherited and overridden ESMF_Base class methods - -!!!!!!!!! added by jhe - public ESMF_TimeIntervalDIVQuot - public ESMF_TimeIntervalIsPositive - ! - - ! !PRIVATE MEMBER FUNCTIONS: - - ! overloaded operator functions - - public operator(/) - private ESMF_TimeIntervalQuotI - - public operator(*) - private ESMF_TimeIntervalProdI - private ESMF_TimeIntervalProdI8 - - ! Inherited and overloaded from ESMF_BaseTime - - public operator(+) - private ESMF_TimeIntervalSum - - public operator(-) - private ESMF_TimeIntervalDiff - - public operator(.EQ.) - private ESMF_TimeIntervalEQ - - public operator(.NE.) - private ESMF_TimeIntervalNE - - public operator(.LT.) - private ESMF_TimeIntervalLT - - public operator(.GT.) - private ESMF_TimeIntervalGT - - public operator(.LE.) - private ESMF_TimeIntervalLE - - public operator(.GE.) - private ESMF_TimeIntervalGE - !EOPI - - !------------------------------------------------------------------------------ - ! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - - !============================================================================== - ! - ! INTERFACE BLOCKS - ! - !============================================================================== - !BOP - ! !INTERFACE: - interface operator(*) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalProdI - module procedure ESMF_TimeIntervalProdI8 - - ! !DESCRIPTION: - ! This interface overloads the * operator for the {\tt ESMF\_TimeInterval} - ! class - ! - !EOP - end interface operator(*) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(/) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalQuotI - - ! !DESCRIPTION: - ! This interface overloads the / operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(/) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(+) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalSum - - ! !DESCRIPTION: - ! This interface overloads the + operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(+) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(-) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalDiff - - ! !DESCRIPTION: - ! This interface overloads the - operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(-) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.EQ.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalEQ - - ! !DESCRIPTION: - ! This interface overloads the .EQ. operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(.EQ.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.NE.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalNE - - ! !DESCRIPTION: - ! This interface overloads the .NE. operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(.NE.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.LT.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalLT - - ! !DESCRIPTION: - ! This interface overloads the .LT. operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(.LT.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.GT.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalGT - - ! !DESCRIPTION: - ! This interface overloads the .GT. operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(.GT.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.LE.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalLE - - ! !DESCRIPTION: - ! This interface overloads the .LE. operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(.LE.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.GE.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeIntervalGE - - ! !DESCRIPTION: - ! This interface overloads the .GE. operator for the - ! {\tt ESMF\_TimeInterval} class - ! - !EOP - end interface operator(.GE.) - ! - !------------------------------------------------------------------------------ - - !============================================================================== - -contains - - !============================================================================== - ! - ! Generic Get/Set routines which use F90 optional arguments - ! - !--------------------------------------------------------------------- - !BOP - ! !IROUTINE: ESMF_TimeIntervalGet - Get value in user-specified units - - ! !INTERFACE: - subroutine ESMF_TimeIntervalGet(timeinterval, StartTimeIn, yy, mm, D, d_r8, S, S_i8, Sn, Sd, TimeString, rc ) - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - type(ESMF_Time), optional, intent(in) :: StartTimeIn - integer, intent(out), optional :: yy - integer, intent(out), optional :: mm - integer, intent(out), optional :: D - real(ESMF_KIND_R8), intent(out), optional :: d_r8 - integer(ESMF_KIND_I8),intent(out), optional :: S_i8 - integer, intent(out), optional :: S - integer, intent(out), optional :: Sn - integer, intent(out), optional :: Sd - character*(*), optional, intent(out) :: TimeString - integer, intent(out), optional :: rc - - - ! !DESCRIPTION: - ! Get the value of the {\tt ESMF\_TimeInterval} in units specified by the - ! user via F90 optional arguments. - ! - ! Time manager represents and manipulates time internally with integers - ! to maintain precision. Hence, user-specified floating point values are - ! converted internally from integers. - ! - ! See {\tt ../include/ESMC\_BaseTime.h} and - ! {\tt ../include/ESMC\_TimeInterval.h} for complete description. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The object instance to query - ! \item[{[YY]}] - ! Integer years (>= 32-bit) - ! \item[{[YYl]}] - ! Integer years (large, >= 64-bit) - ! \item[{[MO]}] - ! Integer months (>= 32-bit) - ! \item[{[MOl]}] - ! Integer months (large, >= 64-bit) - ! \item[{[D]}] - ! Integer days (>= 32-bit) - ! \item[{[Dl]}] - ! Integer days (large, >= 64-bit) - ! \item[{[H]}] - ! Integer hours - ! \item[{[M]}] - ! Integer minutes - ! \item[{[S]}] - ! Integer seconds (>= 32-bit) - ! \item[{[Sl]}] - ! Integer seconds (large, >= 64-bit) - ! \item[{[MS]}] - ! Integer milliseconds - ! \item[{[US]}] - ! Integer microseconds - ! \item[{[NS]}] - ! Integer nanoseconds - ! \item[{[d\_]}] - ! Double precision days - ! \item[{[h\_]}] - ! Double precision hours - ! \item[{[m\_]}] - ! Double precision minutes - ! \item[{[s\_]}] - ! Double precision seconds - ! \item[{[ms\_]}] - ! Double precision milliseconds - ! \item[{[us\_]}] - ! Double precision microseconds - ! \item[{[ns\_]}] - ! Double precision nanoseconds - ! \item[{[Sn]}] - ! Integer fractional seconds - numerator - ! \item[{[Sd]}] - ! Integer fractional seconds - denominator - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.1 - !EOP - type(ESMF_Time) :: lstarttime - logical :: lstarttime_set - logical :: doyear - INTEGER(ESMF_KIND_I8) :: seconds, secondsym, years - INTEGER :: ierr - INTEGER :: mpyi4, iyr,imo,mmon,nmon,mstart,ndays - - ierr = ESMF_FAILURE - - if (present(StartTimeIn)) then - lstarttime_set = .true. - lstarttime = StartTimeIn - else - lstarttime_set = timeinterval%StartTime_set - lstarttime = timeinterval%StartTime - endif - - - CALL timeintchecknormalized( timeinterval, & - 'ESMF_TimeIntervalGet arg1', & - relative_interval=.true. ) - seconds = timeinterval%basetime%S - years = timeinterval%YR - - secondsym = 0 - - IF ( PRESENT( YY ) )THEN - YY = years + timeinterval%MM / MONTHS_PER_YEAR - ! seconds = seconds - years * ( 365_ESMF_KIND_I8 * SECONDS_PER_DAY ) - IF ( PRESENT( MM ) )THEN - mpyi4 = MONTHS_PER_YEAR - MM = MOD( timeinterval%MM, mpyi4) - else - call wrf_error_fatal("ESMF_TimeIntervalGet: requires MM with YY") - END IF - ELSE IF ( PRESENT( MM ) )THEN - MM = timeinterval%MM + years*12 - else if (lstarttime_set) then - ! convert years and months to days carefully - - mpyi4 = MONTHS_PER_YEAR - mmon = timeinterval%mm + timeinterval%yr*mpyi4 - mstart = nmonthinyearsec(lstarttime%yr,lstarttime%basetime,lstarttime%calendar%type) - ! write(6,*) 'tcxti1 ',mmon,lstarttime%yr,mstart,lstarttime%basetime%s - - iyr = lstarttime%yr - if (mmon > 0) then - imo = mstart-1 ! if adding months, start with this month after adding first +1 - else - imo = mstart ! if going backwards, start with last month after first -1 - endif - nmon = 1 - ! do nmon = 1,abs(mmon) - do while (nmon <= abs(mmon)) - if (mmon > 0) then - if (imo == 12 .and. (abs(mmon) - nmon) > 12) then - iyr = iyr + 1 - nmon = nmon + 12 - doyear = .true. - else - imo = imo + 1 - nmon = nmon + 1 - doyear = .false. - endif - else - if (imo == 1 .and. (abs(mmon) - nmon) > 12) then - iyr = iyr - 1 - nmon = nmon + 12 - doyear = .true. - else - imo = imo - 1 - nmon = nmon + 1 - doyear = .false. - endif - endif - - do while (imo > 12) - imo = imo - 12 - iyr = iyr + 1 - enddo - do while (imo < 1) - imo = imo + 12 - iyr = iyr - 1 - enddo - - if (doyear) then - ndays = ndaysinyear(iyr,lstarttime%calendar%type) - else - ndays = ndaysinmonth(iyr,imo,lstarttime%calendar%type) - endif - secondsym = secondsym + (ndays * SECONDS_PER_DAY) - ! write(6,*) 'tcxti2 ',nmon,iyr,imo,ndays - enddo - if (mmon < 0) then - secondsym = -secondsym - endif - ! write(6,*) 'tcxti3 ',mmon,iyr,imo,secondsym - elseif (PRESENT(D) .or. PRESENT(d_r8) .or. present(S) .or. present(S_i8)) then - IF (timeinterval%MM /= 0) then - CALL wrf_error_fatal("ESMF_TimeIntervalGet: Need MM with D,d_r8,S,or S_i8") - endif - if (timeinterval%YR /= 0) then - CALL wrf_error_fatal("ESMF_TimeIntervalGet: Need YY or MM with D,d_r8,S,or S_i8") - endif - END IF - - seconds = seconds+secondsym - - IF ( PRESENT( D ) )THEN - D = seconds / SECONDS_PER_DAY - IF ( PRESENT(S) ) S = mod( seconds, SECONDS_PER_DAY ) - IF ( PRESENT(S_i8)) S_i8 = mod( seconds, SECONDS_PER_DAY ) - ELSE - IF ( PRESENT(S) ) S = seconds - IF ( PRESENT(S_i8)) S_i8 = seconds - END IF - - IF ( PRESENT( d_r8 ) )THEN - D_r8 = REAL( seconds, ESMF_KIND_R8 ) / & - REAL( SECONDS_PER_DAY, ESMF_KIND_R8 ) - END IF - - ! If d_r8 present and sec present - IF ( PRESENT( d_r8 ) )THEN - IF ( PRESENT( S ) .or. present(s_i8) )THEN - CALL wrf_error_fatal( & - "ESMF_TimeIntervalGet: Can not specify d_r8 and S S_i8 values" ) - END IF - END IF - - ierr = ESMF_SUCCESS - - IF ( PRESENT( timeString ) ) THEN - CALL ESMFold_TimeIntervalGetString( timeinterval, timeString, rc=ierr ) - ENDIF - - IF ( PRESENT(Sn) ) THEN - Sn = timeinterval%basetime%Sn - ENDIF - IF ( PRESENT(Sd) ) THEN - Sd = timeinterval%basetime%Sd - ENDIF - - IF ( PRESENT(rc) ) rc = ierr - - end subroutine ESMF_TimeIntervalGet - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalSet - Initialize via user-specified unit set - - ! !INTERFACE: - ! subroutine ESMF_TimeIntervalSet(timeinterval, YY, YYl, MM, MOl, D, Dl, & - ! H, M, S, Sl, MS, US, NS, & - ! d_, d_r8, h_, m_, s_, ms_, us_, ns_, & - ! Sn, Sd, startTime, rc) - subroutine ESMF_TimeIntervalSet(timeinterval, YY, MM, D, & - H, M, S, S_i8, MS, & - d_, d_r8, & - Sn, Sd, startTime, rc) - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(out) :: timeinterval - type(ESMF_Time), intent(in), optional :: StartTime - integer, intent(in), optional :: YY - ! integer(ESMF_KIND_I8), intent(in), optional :: YYl - integer, intent(in), optional :: MM - ! integer(ESMF_KIND_I8), intent(in), optional :: MOl - integer, intent(in), optional :: D - ! integer(ESMF_KIND_I8), intent(in), optional :: Dl - integer, intent(in), optional :: H - integer, intent(in), optional :: M - integer, intent(in), optional :: S - integer(ESMF_KIND_I8), intent(in), optional :: S_i8 - integer, intent(in), optional :: MS - ! integer, intent(in), optional :: US - ! integer, intent(in), optional :: NS - double precision, intent(in), optional :: d_ - double precision, intent(in), optional :: d_r8 - ! double precision, intent(in), optional :: h_ - ! double precision, intent(in), optional :: m_ - ! double precision, intent(in), optional :: s_ - ! double precision, intent(in), optional :: ms_ - ! double precision, intent(in), optional :: us_ - ! double precision, intent(in), optional :: ns_ - integer, intent(in), optional :: Sn - integer, intent(in), optional :: Sd - integer, intent(out), optional :: rc - ! locals - double precision :: din - logical :: dinset - - ! !DESCRIPTION: - ! Set the value of the {\tt ESMF\_TimeInterval} in units specified by - ! the user via F90 optional arguments - ! - ! Time manager represents and manipulates time internally with integers - ! to maintain precision. Hence, user-specified floating point values are - ! converted internally to integers. - ! - ! See {\tt ../include/ESMC\_BaseTime.h} and - ! {\tt ../include/ESMC\_TimeInterval.h} for complete description. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The object instance to initialize - ! \item[{[YY]}] - ! Integer number of interval years (>= 32-bit) - ! \item[{[YYl]}] - ! Integer number of interval years (large, >= 64-bit) - ! \item[{[MM]}] - ! Integer number of interval months (>= 32-bit) - ! \item[{[MOl]}] - ! Integer number of interval months (large, >= 64-bit) - ! \item[{[D]}] - ! Integer number of interval days (>= 32-bit) - ! \item[{[Dl]}] - ! Integer number of interval days (large, >= 64-bit) - ! \item[{[H]}] - ! Integer hours - ! \item[{[M]}] - ! Integer minutes - ! \item[{[S]}] - ! Integer seconds (>= 32-bit) - ! \item[{[Sl]}] - ! Integer seconds (large, >= 64-bit) - ! \item[{[MS]}] - ! Integer milliseconds - ! \item[{[US]}] - ! Integer microseconds - ! \item[{[NS]}] - ! Integer nanoseconds - ! \item[{[d\_]}] - ! Double precision days - ! \item[{[h\_]}] - ! Double precision hours - ! \item[{[m\_]}] - ! Double precision minutes - ! \item[{[s\_]}] - ! Double precision seconds - ! \item[{[ms\_]}] - ! Double precision milliseconds - ! \item[{[us\_]}] - ! Double precision microseconds - ! \item[{[ns\_]}] - ! Double precision nanoseconds - ! \item[{[Sn]}] - ! Integer fractional seconds - numerator - ! \item[{[Sd]}] - ! Integer fractional seconds - denominator - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - - IF ( PRESENT(rc) ) rc = ESMF_FAILURE - - timeinterval%startTime_set = .false. - if (present(startTime)) then - timeinterval%startTime = startTime - timeinterval%startTime_set = .true. - endif - - ! note that YR and MM are relative - timeinterval%YR = 0 - IF ( PRESENT( YY ) ) THEN - timeinterval%YR = YY - ENDIF - timeinterval%MM = 0 - IF ( PRESENT( MM ) ) THEN - timeinterval%MM = MM - ENDIF - - if (present(d_) .and. present(d_r8)) then - CALL wrf_error_fatal( & - "ESMF_TimeIntervalSet: Cannot specify both d_r8 and d_") - endif - dinset = .false. - if (present(d_)) then - din = d_ - dinset = .true. - endif - if (present(d_r8)) then - din = d_r8 - dinset = .true. - endif - IF ( dinset .AND. PRESENT( D ) ) THEN - CALL wrf_error_fatal( & - "ESMF_TimeIntervalSet: Cannot specify both D and d_ or d_r8") - ENDIF - - timeinterval%basetime%S = 0 - IF ( .NOT. dinset ) THEN - IF ( PRESENT( D ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( SECONDS_PER_DAY * INT( D, ESMF_KIND_I8 ) ) - ENDIF - !$$$ push H,M,S,Sn,Sd,MS down into BaseTime constructor - IF ( PRESENT( H ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) ) - ENDIF - IF ( PRESENT( M ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) ) - ENDIF - IF ( PRESENT( S ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - INT( S, ESMF_KIND_I8 ) - ENDIF - IF ( PRESENT( S_i8 ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( S_i8) - ENDIF - ELSE - timeinterval%basetime%S = timeinterval%basetime%S + & - INT( din * SECONDS_PER_DAY, ESMF_KIND_I8 ) - ENDIF - IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN - CALL wrf_error_fatal( & - "ESMF_TimeIntervalSet: Must specify Sd if Sn is specified") - ENDIF - IF ( PRESENT( Sd ) .AND. PRESENT( MS ) ) THEN - CALL wrf_error_fatal( & - "ESMF_TimeIntervalSet: Must not specify both Sd and MS") - ENDIF - timeinterval%basetime%Sn = 0 - timeinterval%basetime%Sd = 0 - IF ( PRESENT( MS ) ) THEN - timeinterval%basetime%Sn = MS - timeinterval%basetime%Sd = 1000_ESMF_KIND_I8 - ELSE IF ( PRESENT( Sd ) ) THEN - timeinterval%basetime%Sd = Sd - IF ( PRESENT( Sn ) ) THEN - timeinterval%basetime%Sn = Sn - ENDIF - ENDIF - CALL normalize_timeint( timeinterval ) - - IF ( PRESENT(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_TimeIntervalSet - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMFold_TimeIntervalGetString - Get time interval value in string format - - ! !INTERFACE: - subroutine ESMFold_TimeIntervalGetString(timeinterval, TimeString, rc) - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - character*(*), intent(out) :: TimeString - integer, intent(out), optional :: rc - ! locals - ! integer :: signnormtimeint - LOGICAL :: negative - INTEGER(ESMF_KIND_I8) :: iS, iSn, iSd, H, M, S, MM, D, YY - character (len=1) :: signstr - - ! !DESCRIPTION: - ! Convert {\tt ESMF\_TimeInterval}'s value into string format - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The object instance to convert - ! \item[TimeString] - ! The string to return - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.9 - !EOP - - ! NOTE: Sn, and Sd are not yet included in the returned string... - !PRINT *,'DEBUG ESMFold_TimeIntervalGetString(): YR,MM,S,Sn,Sd = ', & - ! timeinterval%YR, & - ! timeinterval%MM, & - ! timeinterval%basetime%S, & - ! timeinterval%basetime%Sn, & - ! timeinterval%basetime%Sd - - negative = ( signnormtimeint( timeInterval ) == -1 ) - IF ( negative ) THEN - iS = -timeinterval%basetime%S - iSn = -timeinterval%basetime%Sn - signstr = '-' - ELSE - iS = timeinterval%basetime%S - iSn = timeinterval%basetime%Sn - signstr = '' - ENDIF - iSd = timeinterval%basetime%Sd - - D = iS / SECONDS_PER_DAY - H = mod( iS, SECONDS_PER_DAY ) / SECONDS_PER_HOUR - M = mod( iS, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE - S = mod( iS, SECONDS_PER_MINUTE ) - - !$$$here... need to print Sn and Sd when they are used ??? - - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalGetString-arg1', & - relative_interval=.true. ) - IF ( (timeinterval%MM == 0) .AND. (timeinterval%YR == 0) )THEN - write(TimeString,FMT="(A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & - TRIM(signstr), D, H, M, S - ELSEif (timeinterval%YR == 0) then - MM = timeinterval%MM - write(TimeString,FMT="(I4.4, '_Months_',A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & - MM, TRIM(signstr), D, H, M, S - else - YY = timeinterval%YR - MM = timeinterval%MM - write(TimeString,FMT="(I6.6,'_Years_',I4.4, '_Months_',A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & - YY, MM, TRIM(signstr), D, H, M, S - END IF - - !write(0,*)'TimeIntervalGetString Sn ',timeinterval%basetime%Sn,' Sd ',timeinterval%basetime%Sd - - rc = ESMF_SUCCESS - - end subroutine ESMFold_TimeIntervalGetString - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalAbsValue - Get the absolute value of a time interval - - ! !INTERFACE: - function ESMF_TimeIntervalAbsValue(timeinterval) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalAbsValue - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - ! !LOCAL: - integer :: rc - - ! !DESCRIPTION: - ! Return a {\tt ESMF\_TimeInterval}'s absolute value. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The object instance to take the absolute value of. - ! Absolute value returned as value of function. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.8 - !EOP - ESMF_TimeIntervalAbsValue = timeinterval - !$$$here... move implementation into BaseTime - ESMF_TimeIntervalAbsValue%basetime%S = & - abs(ESMF_TimeIntervalAbsValue%basetime%S) - ESMF_TimeIntervalAbsValue%basetime%Sn = & - abs(ESMF_TimeIntervalAbsValue%basetime%Sn ) - ! - ESMF_TimeIntervalAbsValue%MM = & - abs(ESMF_TimeIntervalAbsValue%MM) - ESMF_TimeIntervalAbsValue%YR = & - abs(ESMF_TimeIntervalAbsValue%YR) - - end function ESMF_TimeIntervalAbsValue - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalNegAbsValue - Get the negative absolute value of a time interval - - ! !INTERFACE: - function ESMF_TimeIntervalNegAbsValue(timeinterval) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalNegAbsValue - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - ! !LOCAL: - integer :: rc - - ! !DESCRIPTION: - ! Return a {\tt ESMF\_TimeInterval}'s negative absolute value. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The object instance to take the negative absolute value of. - ! Negative absolute value returned as value of function. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.8 - !EOP - ESMF_TimeIntervalNegAbsValue = timeinterval - !$$$here... move implementation into BaseTime - ESMF_TimeIntervalNegAbsValue%basetime%S = & - -abs(ESMF_TimeIntervalNegAbsValue%basetime%S) - ESMF_TimeIntervalNegAbsValue%basetime%Sn = & - -abs(ESMF_TimeIntervalNegAbsValue%basetime%Sn ) - ! - ESMF_TimeIntervalNegAbsValue%MM = & - -abs(ESMF_TimeIntervalNegAbsValue%MM ) - ESMF_TimeIntervalNegAbsValue%YR = & - -abs(ESMF_TimeIntervalNegAbsValue%YR ) - - end function ESMF_TimeIntervalNegAbsValue - - !------------------------------------------------------------------------------ - ! - ! This section includes overloaded operators defined only for TimeInterval - ! (not inherited from BaseTime) - ! Note: these functions do not have a return code, since F90 forbids more - ! than 2 arguments for arithmetic overloaded operators - ! - !------------------------------------------------------------------------------ - - ! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder - function ESMF_TimeIntervalDIVQuot(timeinterval1, timeinterval2) - - ! !RETURN VALUE: - INTEGER :: ESMF_TimeIntervalDIVQuot - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - ! !LOCAL - INTEGER :: retval, isgn, rc - type(ESMF_TimeInterval) :: zero, i1,i2 - - ! !DESCRIPTION: - ! Returns timeinterval1 divided by timeinterval2 as a fraction quotient. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! The dividend - ! \item[timeinterval2] - ! The divisor - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.5 - !EOP - - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDIVQuot arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDIVQuot arg2' ) - - call ESMF_TimeIntervalSet( zero, rc=rc ) - i1 = timeinterval1 - i2 = timeinterval2 - isgn = 1 - if ( i1 .LT. zero ) then - i1 = WRFADDITION_TimeIntervalProdI(i1, -1) - isgn = -isgn - endif - if ( i2 .LT. zero ) then - i2 = WRFADDITION_TimeIntervalProdI(i2, -1) - isgn = -isgn - endif - ! repeated subtraction - retval = 0 - DO WHILE ( i1 .GE. i2 ) - i1 = i1 - i2 - retval = retval + 1 - ENDDO - retval = retval * isgn - - ESMF_TimeIntervalDIVQuot = retval - - end function ESMF_TimeIntervalDIVQuot - ! added by jhe - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: WRFADDITION_TimeIntervalProdI - Multiply a time interval by an - ! integer - - ! !INTERFACE: - function WRFADDITION_TimeIntervalProdI(timeinterval, multiplier) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: WRFADDITION_TimeIntervalProdI - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - integer, intent(in) :: multiplier - ! !LOCAL: - integer :: rc - - ! !DESCRIPTION: - ! Multiply a {\tt ESMF\_TimeInterval} by an integer, return product - ! as a - ! {\tt ESMF\_TimeInterval} - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The multiplicand - ! \item[mutliplier] - ! Integer multiplier - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.7, TMG7.2 - !EOP - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdICarg1') - - CALL ESMF_TimeIntervalSet( WRFADDITION_TimeIntervalProdI, rc=rc ) - !$$$move this into overloaded operator(*) in BaseTime - WRFADDITION_TimeIntervalProdI%basetime%S = & - timeinterval%basetime%S * INT( multiplier, ESMF_KIND_I8 ) - WRFADDITION_TimeIntervalProdI%basetime%Sn = & - timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 ) - ! Don't multiply Sd - WRFADDITION_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd - CALL normalize_timeint( WRFADDITION_TimeIntervalProdI ) - - end function WRFADDITION_TimeIntervalProdI - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalQuotI - Divide time interval by an integer, return time interval result - - ! !INTERFACE: - function ESMF_TimeIntervalQuotI(timeinterval, divisor) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalQuotI - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - integer, intent(in) :: divisor - - ! !DESCRIPTION: - ! Divides a {\tt ESMF\_TimeInterval} by an integer divisor, returns - ! quotient as a {\tt ESMF\_TimeInterval} - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The dividend - ! \item[divisor] - ! Integer divisor - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.6, TMG5.3, TMG7.2 - !EOP - - !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() A: S,Sn,Sd = ', & - ! timeinterval%basetime%S,timeinterval%basetime%Sn,timeinterval%basetime%Sd - !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() A: divisor = ', divisor - - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalQuotI arg1' ) - - IF ( divisor == 0 ) THEN - CALL wrf_error_fatal( 'ESMF_TimeIntervalQuotI: divide by zero' ) - ENDIF - ESMF_TimeIntervalQuotI = timeinterval - !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() B: S,Sn,Sd = ', & - ! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd - ESMF_TimeIntervalQuotI%basetime = timeinterval%basetime / divisor - !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() C: S,Sn,Sd = ', & - ! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd - - CALL normalize_timeint( ESMF_TimeIntervalQuotI ) - !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() D: S,Sn,Sd = ', & - ! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd - - end function ESMF_TimeIntervalQuotI - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalProdI - Multiply a time interval by an integer - - ! !INTERFACE: - function ESMF_TimeIntervalProdI(timeinterval, multiplier) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalProdI - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - integer, intent(in) :: multiplier - ! !LOCAL: - integer :: rc - - ! !DESCRIPTION: - ! Multiply a {\tt ESMF\_TimeInterval} by an integer, return product as a - ! {\tt ESMF\_TimeInterval} - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The multiplicand - ! \item[mutliplier] - ! Integer multiplier - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.7, TMG7.2 - !EOP - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdI arg1', & - relative_interval=.true. ) - - CALL ESMF_TimeIntervalSet( ESMF_TimeIntervalProdI, rc=rc ) - !$$$move this into overloaded operator(*) in BaseTime - ESMF_TimeIntervalProdI%basetime%S = & - timeinterval%basetime%S * INT( multiplier, ESMF_KIND_I8 ) - ESMF_TimeIntervalProdI%basetime%Sn = & - timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 ) - ! Don't multiply Sd - ESMF_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd - ESMF_TimeIntervalProdI%MM = timeinterval%MM * multiplier - ESMF_TimeIntervalProdI%YR = timeinterval%YR * multiplier - CALL normalize_timeint( ESMF_TimeIntervalProdI ) - - end function ESMF_TimeIntervalProdI - - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalProdI8 - Multiply a time interval by an integer - - ! !INTERFACE: - function ESMF_TimeIntervalProdI8(timeinterval, multiplier) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalProdI8 - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - integer(kind=ESMF_KIND_I8), intent(in) :: multiplier - ! !LOCAL: - integer :: rc - - ! !DESCRIPTION: - ! Multiply a {\tt ESMF\_TimeInterval} by an integer, return product as a - ! {\tt ESMF\_TimeInterval} - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! The multiplicand - ! \item[mutliplier] - ! Integer multiplier - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.7, TMG7.2 - !EOP - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdI arg1', & - relative_interval=.true. ) - - CALL ESMF_TimeIntervalSet( ESMF_TimeIntervalProdI8, rc=rc ) - !$$$move this into overloaded operator(*) in BaseTime - ESMF_TimeIntervalProdI8%basetime%S = & - timeinterval%basetime%S * multiplier - ESMF_TimeIntervalProdI8%basetime%Sn = & - timeinterval%basetime%Sn * multiplier - ! Don't multiply Sd - ESMF_TimeIntervalProdI8%basetime%Sd = timeinterval%basetime%Sd - ESMF_TimeIntervalProdI8%MM = timeinterval%MM * multiplier - ESMF_TimeIntervalProdI8%YR = timeinterval%YR * multiplier - CALL normalize_timeint( ESMF_TimeIntervalProdI8 ) - - end function ESMF_TimeIntervalProdI8 - - - !------------------------------------------------------------------------------ - ! - ! This section includes the inherited ESMF_BaseTime class overloaded operators - ! - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalSum - Add two time intervals together - - ! !INTERFACE: - function ESMF_TimeIntervalSum(timeinterval1, timeinterval2) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalSum - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - ! !LOCAL: - integer :: rc - ! !DESCRIPTION: - ! Add two {\tt ESMF\_TimeIntervals}, return sum as a - ! {\tt ESMF\_TimeInterval}. Maps overloaded (+) operator interface - ! function to {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! The augend - ! \item[timeinterval2] - ! The addend - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, - ! TMG7.2 - !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalSum arg1', & - relative_interval=.true. ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalSum arg2', & - relative_interval=.true. ) - - ESMF_TimeIntervalSum = timeinterval1 - ESMF_TimeIntervalSum%basetime = ESMF_TimeIntervalSum%basetime + & - timeinterval2%basetime - ESMF_TimeIntervalSum%MM = ESMF_TimeIntervalSum%MM + & - timeinterval2%MM - ESMF_TimeIntervalSum%YR = ESMF_TimeIntervalSum%YR + & - timeinterval2%YR - - CALL normalize_timeint( ESMF_TimeIntervalSum ) - - end function ESMF_TimeIntervalSum - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalDiff - Subtract one time interval from another - - ! !INTERFACE: - function ESMF_TimeIntervalDiff(timeinterval1, timeinterval2) - - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeIntervalDiff - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - ! !LOCAL: - integer :: rc - ! !DESCRIPTION: - ! Subtract timeinterval2 from timeinterval1, return remainder as a - ! {\tt ESMF\_TimeInterval}. - ! Map overloaded (-) operator interface function to {\tt ESMF\_BaseTime} - ! base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! The minuend - ! \item[timeinterval2] - ! The subtrahend - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 - !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDiff arg1', & - relative_interval=.true. ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDiff arg2', & - relative_interval=.true. ) - - ESMF_TimeIntervalDiff = timeinterval1 - ESMF_TimeIntervalDiff%basetime = ESMF_TimeIntervalDiff%basetime - & - timeinterval2%basetime - ESMF_TimeIntervalDiff%MM = ESMF_TimeIntervalDiff%MM - & - timeinterval2%MM - ESMF_TimeIntervalDiff%YR = ESMF_TimeIntervalDiff%YR - & - timeinterval2%YR - CALL normalize_timeint( ESMF_TimeIntervalDiff ) - - end function ESMF_TimeIntervalDiff - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalEQ - Compare two time intervals for equality - - ! !INTERFACE: - function ESMF_TimeIntervalEQ(timeinterval1, timeinterval2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalEQ - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - !DESCRIPTION: - ! Return true if both given time intervals are equal, false otherwise. - ! Maps overloaded (==) operator interface function to {\tt ESMF\_BaseTime} - ! base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! First time interval to compare - ! \item[timeinterval2] - ! Second time interval to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - INTEGER :: res - - CALL timeintcmp(timeinterval1,timeinterval2,res) - ESMF_TimeIntervalEQ = (res .EQ. 0) - - end function ESMF_TimeIntervalEQ - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalNE - Compare two time intervals for inequality - - ! !INTERFACE: - function ESMF_TimeIntervalNE(timeinterval1, timeinterval2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalNE - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - ! !DESCRIPTION: - ! Return true if both given time intervals are not equal, false otherwise. - ! Maps overloaded (/=) operator interface function to {\tt ESMF\_BaseTime} - ! base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! First time interval to compare - ! \item[timeinterval2] - ! Second time interval to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - INTEGER :: res - - CALL timeintcmp(timeinterval1,timeinterval2,res) - ESMF_TimeIntervalNE = (res .NE. 0) - - end function ESMF_TimeIntervalNE - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalLT - Time interval 1 less than time interval 2 ? - - ! !INTERFACE: - function ESMF_TimeIntervalLT(timeinterval1, timeinterval2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalLT - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - ! !DESCRIPTION: - ! Return true if first time interval is less than second time interval, - ! false otherwise. Maps overloaded (<) operator interface function to - ! {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! First time interval to compare - ! \item[timeinterval2] - ! Second time interval to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - INTEGER :: res - - CALL timeintcmp(timeinterval1,timeinterval2,res) - ESMF_TimeIntervalLT = (res .LT. 0) - - end function ESMF_TimeIntervalLT - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalGT - Time interval 1 greater than time interval 2? - - ! !INTERFACE: - function ESMF_TimeIntervalGT(timeinterval1, timeinterval2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalGT - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - ! !DESCRIPTION: - ! Return true if first time interval is greater than second time interval, - ! false otherwise. Maps overloaded (>) operator interface function to - ! {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! First time interval to compare - ! \item[timeinterval2] - ! Second time interval to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - INTEGER :: res - - CALL timeintcmp(timeinterval1,timeinterval2,res) - ESMF_TimeIntervalGT = (res .GT. 0) - - end function ESMF_TimeIntervalGT - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalLE - Time interval 1 less than or equal to time interval 2 ? - - ! !INTERFACE: - function ESMF_TimeIntervalLE(timeinterval1, timeinterval2) - - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalLE - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - ! !DESCRIPTION: - ! Return true if first time interval is less than or equal to second time - ! interval, false otherwise. - ! Maps overloaded (<=) operator interface function to {\tt ESMF\_BaseTime} - ! base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! First time interval to compare - ! \item[timeinterval2] - ! Second time interval to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - INTEGER :: res - - CALL timeintcmp(timeinterval1,timeinterval2,res) - ESMF_TimeIntervalLE = (res .LE. 0) - - end function ESMF_TimeIntervalLE - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalGE - Time interval 1 greater than or equal to time interval 2 ? - - ! !INTERFACE: - function ESMF_TimeIntervalGE(timeinterval1, timeinterval2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalGE - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval1 - type(ESMF_TimeInterval), intent(in) :: timeinterval2 - - ! !DESCRIPTION: - ! Return true if first time interval is greater than or equal to second - ! time interval, false otherwise. Maps overloaded (>=) operator interface - ! function to {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval1] - ! First time interval to compare - ! \item[timeinterval2] - ! Second time interval to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - INTEGER :: res - - CALL timeintcmp(timeinterval1,timeinterval2,res) - ESMF_TimeIntervalGE = (res .GE. 0) - - end function ESMF_TimeIntervalGE - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalIsPositive - Time interval greater than zero? - - ! !INTERFACE: - function ESMF_TimeIntervalIsPositive(timeinterval) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeIntervalIsPositive - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - - ! !LOCALS: - type(ESMF_TimeInterval) :: zerotimeint - integer :: rcint - - ! !DESCRIPTION: - ! Return true if time interval is greater than zero, - ! false otherwise. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! Time interval to compare - ! \end{description} - !EOP - CALL timeintchecknormalized( timeinterval, & - 'ESMF_TimeIntervalIsPositive arg' ) - - CALL ESMF_TimeIntervalSet ( zerotimeint, rc=rcint ) - IF ( rcint /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal( & - 'ESMF_TimeIntervalIsPositive: ESMF_TimeIntervalSet failed' ) - ENDIF - ! hack for bug in PGI 5.1-x - ! ESMF_TimeIntervalIsPositive = timeinterval > zerotimeint - ESMF_TimeIntervalIsPositive = ESMF_TimeIntervalGT( timeinterval, & - zerotimeint ) - end function ESMF_TimeIntervalIsPositive - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeIntervalPrint - Print out a time interval's properties - - ! !INTERFACE: - subroutine ESMF_TimeIntervalPrint(timeinterval, opts, rc) - - ! !ARGUMENTS: - type(ESMF_TimeInterval), intent(in) :: timeinterval - character (len=*), intent(in), optional :: opts - integer, intent(out), optional :: rc - - ! !DESCRIPTION: - ! To support testing/debugging, print out an {\tt ESMF\_TimeInterval}'s - ! properties. - ! - ! The arguments are: - ! \begin{description} - ! \item[timeinterval] - ! Time interval to print out - ! \item[{[opts]}] - ! Print options - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - INTEGER :: ierr - - ierr = ESMF_SUCCESS - call print_a_timeinterval( timeinterval ) - IF ( PRESENT(rc) ) rc = ierr - - end subroutine ESMF_TimeIntervalPrint - - !------------------------------------------------------------------------------ - - ! Exits with error message if timeInt is not normalized. - SUBROUTINE timeintchecknormalized( timeInt, msgstr, relative_interval ) - IMPLICIT NONE - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt - CHARACTER(LEN=*), INTENT(IN) :: msgstr - LOGICAL, INTENT(IN), optional :: relative_interval ! If relative intervals are ok or not - ! locals - CHARACTER(LEN=256) :: outstr - LOGICAL :: non_relative - - IF ( .NOT. PRESENT( relative_interval ) )THEN - non_relative = .true. - ELSE - IF ( relative_interval )THEN - non_relative = .false. - ELSE - non_relative = .true. - END IF - END IF - IF ( non_relative )THEN - IF ( ( timeInt%YR /= 0 ) .OR. & - ( timeInt%MM /= 0 ) ) THEN - outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) - CALL wrf_error_fatal( outstr ) - ENDIF - ELSE - IF ( ( timeInt%YR /= 0 ) .OR. & - ( timeInt%MM < -MONTHS_PER_YEAR) .OR. ( timeInt%MM > MONTHS_PER_YEAR ) ) THEN - ! tcraig, don't require normalize TimeInterval for relative diffs - ! outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) - ! CALL wrf_error_fatal( outstr ) - ENDIF - END IF - END SUBROUTINE timeintchecknormalized - - !============================================================================== - SUBROUTINE print_a_timeinterval( time ) - IMPLICIT NONE - type(ESMF_TimeInterval) time - character*128 :: s - integer rc - CALL ESMFold_TimeIntervalGetString( time, s, rc ) - write(6,*)'Print a time interval|',time%yr, time%mm, time%basetime%s, time%starttime_set, time%starttime%calendar%type%caltype - write(6,*)'Print a time interval|',TRIM(s),'|' - return - END SUBROUTINE print_a_timeinterval - - !============================================================================== - - SUBROUTINE timeintcmp(timeint1in, timeint2in, retval ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval - ! - ! !ARGUMENTS: - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1in - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2in - - TYPE(ESMF_TimeInterval) :: timeint1 - TYPE(ESMF_TimeInterval) :: timeint2 - - timeint1 = timeint1in - timeint2 = timeint2in - call normalize_timeint(timeint1) - call normalize_timeint(timeint2) - - IF ( (timeint1%MM /= timeint2%MM) .and. (timeint1%YR /= timeint2%YR) )THEN - CALL wrf_error_fatal( & - 'timeintcmp: Can not compare two intervals with different months and years' ) - END IF - if (timeint1%YR .gt. timeint2%YR) then - retval = 1 - elseif (timeint1%YR .lt. timeint2%YR) then - retval = -1 - else - if (timeint1%MM .gt. timeint2%MM) then - retval = 1 - elseif (timeint1%MM .lt. timeint2%MM) then - retval = 1 - else - CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, & - timeint1%basetime%Sd, & - timeint2%basetime%S, timeint2%basetime%Sn, & - timeint2%basetime%Sd, retval ) - endif - endif - - END SUBROUTINE timeintcmp - - !============================================================================== - - SUBROUTINE normalize_timeint( timeInt ) - IMPLICIT NONE - TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt - INTEGER :: mpyi4 - - ! normalize basetime - ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match - ! YR and MM are ignored - - CALL normalize_basetime( timeInt%basetime ) - - ! Rollover months to years - - mpyi4 = MONTHS_PER_YEAR - IF ( abs(timeInt%MM) .GE. MONTHS_PER_YEAR ) THEN - timeInt%YR = timeInt%YR + timeInt%MM/MONTHS_PER_YEAR - timeInt%MM = mod(timeInt%MM,mpyi4) - ENDIF - - ! make sure yr and mm have same sign - - IF (timeInt%YR * timeInt%MM < 0) then - if (timeInt%YR > 0) then - timeInt%MM = timeInt%MM + MONTHS_PER_YEAR - timeInt%YR = timeInt%YR - 1 - endif - if (timeInt%YR < 0) then - timeInt%MM = timeInt%MM - MONTHS_PER_YEAR - timeInt%YR = timeInt%YR + 1 - endif - endif - - END SUBROUTINE normalize_timeint - - !============================================================================== - - integer FUNCTION signnormtimeint ( timeInt ) - ! Compute the sign of a time interval. - ! YR and MM fields are *IGNORED*. - ! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs. - IMPLICIT NONE - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt - LOGICAL :: positive, negative - - positive = .FALSE. - negative = .FALSE. - signnormtimeint = 0 - ! Note that Sd is required to be non-negative. This is enforced in - ! normalize_timeint(). - ! Note that Sn is required to be zero when Sd is zero. This is enforced - ! in normalize_timeint(). - IF ( ( timeInt%basetime%S > 0 ) .OR. & - ( timeInt%basetime%Sn > 0 ) ) THEN - positive = .TRUE. - ENDIF - IF ( ( timeInt%basetime%S < 0 ) .OR. & - ( timeInt%basetime%Sn < 0 ) ) THEN - negative = .TRUE. - ENDIF - IF ( positive .AND. negative ) THEN - CALL wrf_error_fatal( & - 'signnormtimeint: signs of fields cannot be mixed' ) - ELSE IF ( positive ) THEN - signnormtimeint = 1 - ELSE IF ( negative ) THEN - signnormtimeint = -1 - ENDIF - END FUNCTION signnormtimeint - !============================================================================== - -end module ESMF_TimeIntervalMod diff --git a/src/esmf_wrf_timemgr/ESMF_TimeMgr.inc b/src/esmf_wrf_timemgr/ESMF_TimeMgr.inc deleted file mode 100644 index 921727b..0000000 --- a/src/esmf_wrf_timemgr/ESMF_TimeMgr.inc +++ /dev/null @@ -1,45 +0,0 @@ -#if 0 -$Id$ - -Earth System Modeling Framework -Copyright 2002-2003, University Corporation for Atmospheric Research, -Massachusetts Institute of Technology, Geophysical Fluid Dynamics -Laboratory, University of Michigan, National Centers for Environmental -Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -NASA Goddard Space Flight Center. -Licensed under the GPL. - -Do not have C++ or F90 style comments in here because this file is processed -by both C++ and F90 compilers. -#endif - -#ifndef ESMF_TimeMgr_INC -#define ESMF_TimeMgr_INC - -#if 0 -!BOP -------------------------------------------------------------------------- - - !DESCRIPTION: - - ESMF TimeMgr include file for F90 - The code in this file implements constants and macros for the TimeMgr... - -------------------------------------------------------------------------- -!EOP -#endif - -#include - -#define SECONDS_PER_DAY 86400_ESMF_KIND_I8 -#define SECONDS_PER_HOUR 3600_ESMF_KIND_I8 -#define SECONDS_PER_MINUTE 60_ESMF_KIND_I8 -#define HOURS_PER_DAY 24_ESMF_KIND_I8 -#define MONTHS_PER_YEAR 12_ESMF_KIND_I8 - -! Note that MAX_ALARMS must match MAX_WRF_ALARMS defined in -! ../../frame/module_domain.F !!! Eliminate this dependence with -! grow-as-you-go AlarmList in ESMF_Clock... -#define MAX_ALARMS 60 - -#endif diff --git a/src/esmf_wrf_timemgr/ESMF_TimeMod.F90 b/src/esmf_wrf_timemgr/ESMF_TimeMod.F90 deleted file mode 100644 index 4d4935b..0000000 --- a/src/esmf_wrf_timemgr/ESMF_TimeMod.F90 +++ /dev/null @@ -1,1572 +0,0 @@ -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the GPL. -! -!============================================================================== -! -! ESMF Time Module -module ESMF_TimeMod - ! - !============================================================================== - ! - ! This file contains the Time class definition and all Time class methods. - ! - !------------------------------------------------------------------------------ - ! INCLUDES -#include - - !============================================================================== - !BOPI - ! !MODULE: ESMF_TimeMod - ! - ! !DESCRIPTION: - ! Part of Time Manager F90 API wrapper of C++ implemenation - ! - ! Defines F90 wrapper entry points for corresponding - ! C++ class {\tt ESMC\_Time} implementation - ! - ! See {\tt ../include/ESMC\_Time.h} for complete description - ! - !------------------------------------------------------------------------------ - ! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! inherit from base time class - use ESMF_BaseTimeMod - - ! associated derived types - use ESMF_TimeIntervalMod - use ESMF_CalendarMod - use ESMF_ShrTimeMod, only : ESMF_Time - ! added by Jhe - use ESMF_Stubs - - implicit none - ! - !------------------------------------------------------------------------------ - ! !PRIVATE TYPES: - private - !------------------------------------------------------------------------------ - ! ! ESMF_Time - ! - ! ! F90 class type to match C++ Time class in size only; - ! ! all dereferencing within class is performed by C++ implementation - - ! move to ESMF_ShrTimeMod - ! type ESMF_Time - ! type(ESMF_BaseTime) :: basetime ! inherit base class - ! ! time instant is expressed as year + basetime - ! integer :: YR - ! type(ESMF_Calendar), pointer :: calendar ! associated calendar - ! end type - !------------------------------------------------------------------------------ - ! !PUBLIC DATA: - - !------------------------------------------------------------------------------ - ! !PUBLIC TYPES: - public ESMF_Time - !------------------------------------------------------------------------------ - ! - ! !PUBLIC MEMBER FUNCTIONS: - public ESMF_TimeGet - public ESMF_TimeSet - public ESMF_TimePrint - - ! Required inherited and overridden ESMF_Base class methods - - public ESMF_TimeCopy - public ESMF_SetYearWidth - - ! !PRIVATE MEMBER FUNCTIONS: - - private ESMF_TimeGetDayOfYear - private ESMF_TimeGetDayOfYearInteger - - ! Inherited and overloaded from ESMF_BaseTime - - public operator(+) - public ESMF_TimeInc - - public operator(-) - private ESMF_TimeDec - private ESMF_TimeDiff - - public operator(.EQ.) - public ESMF_TimeEQ - - public operator(.NE.) - public ESMF_TimeNE - - public operator(.LT.) - public ESMF_TimeLT - - public operator(.GT.) - public ESMF_TimeGT - - public operator(.LE.) - public ESMF_TimeLE - - public operator(.GE.) - public ESMF_TimeGE - - !EOPI - - !------------------------------------------------------------------------------ - ! The following line turns the CVS identifier string into a printable variable. - character(*), parameter, private :: version = & - '$Id$' - - integer :: yearWidth = 4 - - !============================================================================== - ! - ! INTERFACE BLOCKS - ! - !============================================================================== - !BOP - ! !INTERFACE: - interface ESMF_TimeGetDayOfYear - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeGetDayOfYearInteger - - ! !DESCRIPTION: - ! This interface overloads the {\tt ESMF\_GetDayOfYear} method - ! for the {\tt ESMF\_Time} class - ! - !EOP - end interface ESMF_TimeGetDayOfYear - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(+) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeInc, ESMF_TimeInc2 - - ! !DESCRIPTION: - ! This interface overloads the + operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(+) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface assignment (=) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeCopy - - ! !DESCRIPTION: - ! This interface overloads the = operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface assignment (=) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(-) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeDec, ESMF_TimeDec2 - - ! !DESCRIPTION: - ! This interface overloads the - operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(-) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(-) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeDiff - - ! !DESCRIPTION: - ! This interface overloads the - operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(-) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.EQ.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeEQ - - ! !DESCRIPTION: - ! This interface overloads the .EQ. operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(.EQ.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.NE.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeNE - - ! !DESCRIPTION: - ! This interface overloads the .NE. operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(.NE.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.LT.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeLT - - ! !DESCRIPTION: - ! This interface overloads the .LT. operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(.LT.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.GT.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeGT - - ! !DESCRIPTION: - ! This interface overloads the .GT. operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(.GT.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.LE.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeLE - - ! !DESCRIPTION: - ! This interface overloads the .LE. operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(.LE.) - ! - !------------------------------------------------------------------------------ - !BOP - ! !INTERFACE: - interface operator(.GE.) - - ! !PRIVATE MEMBER FUNCTIONS: - module procedure ESMF_TimeGE - - ! !DESCRIPTION: - ! This interface overloads the .GE. operator for the {\tt ESMF\_Time} class - ! - !EOP - end interface operator(.GE.) - ! - !------------------------------------------------------------------------------ - - !============================================================================== - -contains - - !============================================================================== - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeGet - Get value in user-specified units - - ! !INTERFACE: - ! subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & - ! US, NS, d_, h_, m_, s_, ms_, us_, ns_, Sn, Sd, & - ! dayOfYear, dayOfYear_r8, dayOfYear_intvl, & - ! timeString, rc) - - recursive subroutine ESMF_TimeGet(time, YY, MM, DD, D, Dl, H, M, S, MS, & - Sn, Sd, & - dayOfYear, dayOfYear_r8, dayOfYear_intvl, & - timeString, rc) - - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time - integer, intent(out), optional :: YY - ! integer(ESMF_KIND_I8), intent(out), optional :: YRl - integer, intent(out), optional :: MM - integer, intent(out), optional :: DD - integer, intent(out), optional :: D - integer(ESMF_KIND_I8), intent(out), optional :: Dl - integer, intent(out), optional :: H - integer, intent(out), optional :: M - integer, intent(out), optional :: S - ! integer(ESMF_KIND_I8), intent(out), optional :: Sl - integer, intent(out), optional :: MS - ! integer, intent(out), optional :: US - ! integer, intent(out), optional :: NS - ! double precision, intent(out), optional :: d_ - ! double precision, intent(out), optional :: h_ - ! double precision, intent(out), optional :: m_ - ! double precision, intent(out), optional :: s_ - ! double precision, intent(out), optional :: ms_ - ! double precision, intent(out), optional :: us_ - ! double precision, intent(out), optional :: ns_ - integer, intent(out), optional :: Sn - integer, intent(out), optional :: Sd - integer, intent(out), optional :: dayOfYear - real(ESMF_KIND_R8), intent(out), optional :: dayOfYear_r8 - character (len=*), intent(out), optional :: timeString - type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl - integer, intent(out), optional :: rc - - - ! !DESCRIPTION: - ! Get the value of the {\tt ESMF\_Time} in units specified by the user - ! via F90 optional arguments. - ! - ! Time manager represents and manipulates time internally with integers - ! to maintain precision. Hence, user-specified floating point values are - ! converted internally from integers. - ! - ! See {\tt ../include/ESMC\_BaseTime.h and ../include/ESMC\_Time.h} for - ! complete description. - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! The object instance to query - ! \item[{[YY]}] - ! Integer year CCYR (>= 32-bit) - ! \item[{[YRl]}] - ! Integer year CCYR (large, >= 64-bit) - ! \item[{[MM]}] - ! Integer month 1-12 - ! \item[{[DD]}] - ! Integer day of the month 1-31 - ! \item[{[D]}] - ! Integer Julian days (>= 32-bit) - ! \item[{[Dl]}] - ! Integer Julian days (large, >= 64-bit) - ! \item[{[H]}] - ! Integer hours - ! \item[{[M]}] - ! Integer minutes - ! \item[{[S]}] - ! Integer seconds (>= 32-bit) - ! \item[{[Sl]}] - ! Integer seconds (large, >= 64-bit) - ! \item[{[MS]}] - ! Integer milliseconds - ! \item[{[US]}] - ! Integer microseconds - ! \item[{[NS]}] - ! Integer nanoseconds - ! \item[{[d\_]}] - ! Double precision days - ! \item[{[h\_]}] - ! Double precision hours - ! \item[{[m\_]}] - ! Double precision minutes - ! \item[{[s\_]}] - ! Double precision seconds - ! \item[{[ms\_]}] - ! Double precision milliseconds - ! \item[{[us\_]}] - ! Double precision microseconds - ! \item[{[ns\_]}] - ! Double precision nanoseconds - ! \item[{[Sn]}] - ! Integer fractional seconds - numerator - ! \item[{[Sd]}] - ! Integer fractional seconds - denominator - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG2.1, TMG2.5.1, TMG2.5.6 - !EOP - type(ESMF_TimeInterval) :: day_step - integer :: ierr - TYPE(ESMF_Time) :: begofyear - TYPE(ESMF_TimeInterval) :: difftobegofyear - INTEGER :: year, month, dayofmonth, hour, minute, second - INTEGER :: i - INTEGER(ESMF_KIND_I8) :: cnt - - ierr = ESMF_SUCCESS - - IF ( PRESENT( YY ) ) THEN - YY = time%YR - ENDIF - IF ( PRESENT( MM ) ) THEN - CALL timegetmonth( time, MM ) - ENDIF - IF ( PRESENT( DD ) ) THEN - CALL timegetdayofmonth( time, DD ) - ENDIF - - if (present(d) .or. present(dl)) then - cnt = 0 - do i = 0,time%yr-1 - cnt = cnt + ndaysinyear(i,time%calendar%type) - enddo - do i = time%yr,-1 - cnt = cnt - ndaysinyear(i,time%calendar%type) - enddo - call timegetmonth(time,month) - do i = 1,month-1 - cnt = cnt + ndaysinmonth(time%yr,i,time%calendar%type) - enddo - call timegetdayofmonth( time, dayofmonth) - cnt = cnt + dayofmonth - if (present(d)) then - d = cnt - endif - if (present(dl)) then - dl = cnt - endif - endif - ! - !$$$ push HMS down into ESMF_BaseTime - IF ( PRESENT( H ) ) THEN - H = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR - ENDIF - IF ( PRESENT( M ) ) THEN - M = mod( time%basetime%S, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE - ENDIF - IF ( PRESENT( S ) ) THEN - S = mod( time%basetime%S, SECONDS_PER_MINUTE ) - ENDIF - - IF ( PRESENT( S ) .AND. PRESENT( DD ) ) THEN - IF ( ( .NOT. PRESENT( H ) ) .AND. ( .NOT. PRESENT( M ) ) ) THEN - S = mod( time%basetime%S, SECONDS_PER_DAY ) - ENDIF - ENDIF - IF ( PRESENT( MS ) ) THEN - IF ( time%basetime%Sd /= 0 ) THEN - MS = NINT( ( time%basetime%Sn*1.0D0 / time%basetime%Sd*1.0D0 ) * 1000.0D0 ) - ELSE - MS = 0 - ENDIF - ENDIF - IF ( PRESENT( Sd ) .AND. PRESENT( Sn ) ) THEN - Sd = time%basetime%Sd - Sn = time%basetime%Sn - ENDIF - IF ( PRESENT( dayOfYear ) ) THEN - CALL ESMF_TimeGetDayOfYear( time, dayOfYear, rc=ierr ) - ENDIF - IF ( PRESENT( timeString ) ) THEN - ! This duplication for YMD is an optimization that avoids calling - ! timegetmonth() and timegetdayofmonth() when it is not needed. - year = time%YR - CALL timegetmonth( time, month ) - CALL timegetdayofmonth( time, dayofmonth ) - !$$$ push HMS down into ESMF_BaseTime - hour = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR - minute = mod( time%basetime%S, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE - second = mod( time%basetime%S, SECONDS_PER_MINUTE ) - CALL ESMFold_TimeGetString( year, month, dayofmonth, & - hour, minute, second, timeString ) - ENDIF - IF ( PRESENT( dayOfYear_intvl ) ) THEN - year = time%YR - CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, & - calendar=time%calendar, rc=ierr ) - IF ( ierr == ESMF_FAILURE)THEN - rc = ierr - RETURN - END IF - dayOfYear_intvl = time - begofyear - ENDIF - IF ( PRESENT( dayOfYear_r8) ) THEN - year = time%YR - CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, & - calendar=time%calendar, rc=ierr ) - IF ( ierr == ESMF_FAILURE)THEN - rc = ierr - RETURN - END IF - CALL ESMF_TimeIntervalSet( day_step, d=1, s=0, rc=ierr ) - IF ( ierr == ESMF_FAILURE)THEN - rc = ierr - RETURN - END IF - difftobegofyear = time - begofyear + day_step - CALL ESMF_TimeIntervalGet( difftobegofyear, d_r8=dayOfYear_r8, rc=ierr ) - IF ( ierr == ESMF_FAILURE)THEN - rc = ierr - RETURN - END IF - ENDIF - - IF ( PRESENT( rc ) ) THEN - rc = ierr - ENDIF - - end subroutine ESMF_TimeGet - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeSet - Initialize via user-specified unit set - - ! !INTERFACE: - ! subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & - ! MS, US, NS, d_, h_, m_, s_, ms_, us_, ns_, & - ! Sn, Sd, calendar, calkindflag, rc) - - subroutine ESMF_TimeSet(time, YY, MM, DD, D, Dl, H, M, S, & - MS, & - Sn, Sd, calendar, calkindflag, rc) - - ! !ARGUMENTS: - type(ESMF_Time), intent(inout) :: time - integer, intent(in), optional :: YY - ! integer(ESMF_KIND_I8), intent(in), optional :: YRl - integer, intent(in), optional :: MM - integer, intent(in), optional :: DD - integer, intent(in), optional :: D - integer(ESMF_KIND_I8), intent(in), optional :: Dl - integer, intent(in), optional :: H - integer, intent(in), optional :: M - integer, intent(in), optional :: S - ! integer(ESMF_KIND_I8), intent(in), optional :: Sl - integer, intent(in), optional :: MS - ! integer, intent(in), optional :: US - ! integer, intent(in), optional :: NS - ! double precision, intent(in), optional :: d_ - ! double precision, intent(in), optional :: h_ - ! double precision, intent(in), optional :: m_ - ! double precision, intent(in), optional :: s_ - ! double precision, intent(in), optional :: ms_ - ! double precision, intent(in), optional :: us_ - ! double precision, intent(in), optional :: ns_ - integer, intent(in), optional :: Sn - integer, intent(in), optional :: Sd - type(ESMF_Calendar), intent(in), target, optional :: calendar - type(ESMF_CalKind_Flag), intent(in), optional :: calkindflag - integer, intent(out), optional :: rc - - ! locals - INTEGER :: ierr - logical :: dset - - ! !DESCRIPTION: - ! Initializes a {\tt ESMF\_Time} with a set of user-specified units - ! via F90 optional arguments. - ! - ! Time manager represents and manipulates time internally with integers - ! to maintain precision. Hence, user-specified floating point values are - ! converted internally to integers. - ! - ! See {\tt ../include/ESMC\_BaseTime.h and ../include/ESMC\_Time.h} for - ! complete description. - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! The object instance to initialize - ! \item[{[YY]}] - ! Integer year CCYR (>= 32-bit) - ! \item[{[YRl]}] - ! Integer year CCYR (large, >= 64-bit) - ! \item[{[MM]}] - ! Integer month 1-12 - ! \item[{[DD]}] - ! Integer day of the month 1-31 - ! \item[{[D]}] - ! Integer Julian days (>= 32-bit) - ! \item[{[Dl]}] - ! Integer Julian days (large, >= 64-bit) - ! \item[{[H]}] - ! Integer hours - ! \item[{[M]}] - ! Integer minutes - ! \item[{[S]}] - ! Integer seconds (>= 32-bit) - ! \item[{[Sl]}] - ! Integer seconds (large, >= 64-bit) - ! \item[{[MS]}] - ! Integer milliseconds - ! \item[{[US]}] - ! Integer microseconds - ! \item[{[NS]}] - ! Integer nanoseconds - ! \item[{[d\_]}] - ! Double precision days - ! \item[{[h\_]}] - ! Double precision hours - ! \item[{[m\_]}] - ! Double precision minutes - ! \item[{[s\_]}] - ! Double precision seconds - ! \item[{[ms\_]}] - ! Double precision milliseconds - ! \item[{[us\_]}] - ! Double precision microseconds - ! \item[{[ns\_]}] - ! Double precision nanoseconds - ! \item[{[Sn]}] - ! Integer fractional seconds - numerator - ! \item[{[Sd]}] - ! Integer fractional seconds - denominator - ! \item[{[cal]}] - ! Associated {\tt Calendar} - ! \item[{[tz]}] - ! Associated timezone (hours offset from GMT, e.g. EST = -5) - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - ! PRINT *,'DEBUG: BEGIN ESMF_TimeSet()' - !$$$ push this down into ESMF_BaseTime constructor - - IF ( PRESENT( rc ) ) then - rc = ESMF_FAILURE - ENDIF - - time%YR = 0 - time%basetime%S = 0 - time%basetime%Sn = 0 - time%basetime%Sd = 0 - - IF ( PRESENT(calendar) )THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): using passed-in calendar' - IF ( .not. ESMF_CalendarInitialized( calendar ) )THEN - call wrf_error_fatal( "Error:: ESMF_CalendarCreate not "// & - "called on input Calendar") - END IF - ! call flush(6) - ! write(6,*) 'tcx1 ESMF_TimeSet point to calendar' - ! call flush(6) - time%Calendar => calendar - ELSE - ! PRINT *,'DEBUG: ESMF_TimeSet(): using default calendar' - ! for the sake of WRF, check ESMF_IsInitialized, revised by Juanxiong He - IF ( .not. ESMF_IsInitialized() )THEN - call wrf_error_fatal( "Error:: ESMF_Initialize not called") - END IF - ! IF ( .not. ESMF_CalendarInitialized( defaultCal ) )THEN - ! call wrf_error_fatal( "Error:: ESMF_Initialize not called") - ! END IF - if (present(calkindflag)) then - ! write(6,*) 'tcx2 ESMF_TimeSet point to calendarkindflag',calkindflag%caltype - ! call flush(6) - if (calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype) then - time%Calendar => gregorianCal - elseif (calkindflag%caltype == ESMF_CALKIND_NOLEAP%caltype) then - time%Calendar => noleapCal - else - call wrf_error_fatal( "Error:: ESMF_TimeSet invalid calkindflag") - endif - else - ! write(6,*) 'tcx3 ESMF_TimeSet point to defaultcal' - ! call flush(6) - time%Calendar => defaultCal - endif - END IF - ! write(6,*) 'tcxn ESMF_TimeSet ',ESMF_CALKIND_NOLEAP%caltype - ! call flush(6) - ! write(6,*) 'tcxg ESMF_TimeSet ',ESMF_CALKIND_GREGORIAN%caltype - ! call flush(6) - ! write(6,*) 'tcxt ESMF_TimeSet ',time%calendar%type%caltype - ! call flush(6) - - dset = .false. - if (present(D)) then - if (present(Dl)) CALL wrf_error_fatal( 'ESMF_TimeSet: D and Dl not both valid') - time%basetime%s = SECONDS_PER_DAY * INT(D-1,ESMF_KIND_I8) - dset=.true. - elseif (present(Dl)) then - time%basetime%s = SECONDS_PER_DAY * Dl-1_ESMF_KIND_I8 - dset=.true. - endif - - IF ( PRESENT( YY ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): YY = ',YY - if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') - time%YR = YY - ENDIF - IF ( PRESENT( MM ) ) THEN - if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') - ! PRINT *,'DEBUG: ESMF_TimeSet(): MM = ',MM - CALL timeaddmonths( time, MM, ierr ) - IF ( ierr == ESMF_FAILURE ) THEN - IF ( PRESENT( rc ) ) THEN - rc = ESMF_FAILURE - RETURN - ELSE - CALL wrf_error_fatal( 'ESMF_TimeSet: MM out of range' ) - ENDIF - ENDIF - ! PRINT *,'DEBUG: ESMF_TimeSet(): back from timeaddmonths' - ENDIF - IF ( PRESENT( DD ) ) THEN - if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') - !$$$ no check for DD in range of days of month MM yet - !$$$ Must separate D and DD for correct interface! - ! PRINT *,'DEBUG: ESMF_TimeSet(): DD = ',DD - time%basetime%S = time%basetime%S + & - ( SECONDS_PER_DAY * INT( (DD-1), ESMF_KIND_I8 ) ) - ENDIF - !$$$ push H,M,S,Sn,Sd,MS down into ESMF_BaseTime constructor - IF ( PRESENT( H ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): H = ',H - time%basetime%S = time%basetime%S + & - ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) ) - ENDIF - IF ( PRESENT( M ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): M = ',M - time%basetime%S = time%basetime%S + & - ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) ) - ENDIF - IF ( PRESENT( S ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): S = ',S - time%basetime%S = time%basetime%S + & - INT( S, ESMF_KIND_I8 ) - ENDIF - IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN - CALL wrf_error_fatal( & - "ESMF_TimeSet: Must specify Sd if Sn is specified") - ENDIF - IF ( PRESENT( Sd ) .AND. PRESENT( MS ) ) THEN - CALL wrf_error_fatal( & - "ESMF_TimeSet: Must not specify both Sd and MS") - ENDIF - time%basetime%Sn = 0 - time%basetime%Sd = 0 - IF ( PRESENT( MS ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): MS = ',MS - time%basetime%Sn = MS - time%basetime%Sd = 1000_ESMF_KIND_I8 - ELSE IF ( PRESENT( Sd ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): Sd = ',Sd - time%basetime%Sd = Sd - IF ( PRESENT( Sn ) ) THEN - ! PRINT *,'DEBUG: ESMF_TimeSet(): Sn = ',Sn - time%basetime%Sn = Sn - ENDIF - ENDIF - - ! PRINT *,'DEBUG: ESMF_TimeSet(): calling normalize_time()' - !$$$DEBUG - !IF ( time%basetime%Sd > 0 ) THEN - ! PRINT *,'DEBUG ESMF_TimeSet() before normalize: S,Sn,Sd = ', & - ! time%basetime%S, time%basetime%Sn, time%basetime%Sd - !ENDIF - !$$$END DEBUG - CALL normalize_time( time ) - !$$$DEBUG - !IF ( time%basetime%Sd > 0 ) THEN - ! PRINT *,'DEBUG ESMF_TimeSet() after normalize: S,Sn,Sd = ', & - ! time%basetime%S, time%basetime%Sn, time%basetime%Sd - !ENDIF - !$$$END DEBUG - - ! PRINT *,'DEBUG: ESMF_TimeSet(): back from normalize_time()' - IF ( PRESENT( rc ) ) THEN - rc = ESMF_SUCCESS - ENDIF - - end subroutine ESMF_TimeSet - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMFold_TimeGetString - Get time instant value in string format - - ! !INTERFACE: - subroutine ESMFold_TimeGetString( year, month, dayofmonth, & - hour, minute, second, TimeString ) - - ! !ARGUMENTS: - integer, intent(in) :: year - integer, intent(in) :: month - integer, intent(in) :: dayofmonth - integer, intent(in) :: hour - integer, intent(in) :: minute - integer, intent(in) :: second - character*(*), intent(out) :: TimeString - character*(256) :: TimeFormatString - ! !DESCRIPTION: - ! Convert {\tt ESMF\_Time}'s value into ISO 8601 format YYYY-MM-DDThh:mm:ss - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! The object instance to convert - ! \item[TimeString] - ! The string to return - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG2.4.7 - !EOP - - !PRINT *,'DEBUG: ESMF_TimePrint(): YR,S,Sn,Sd = ',time%YR,time%basetime%S,time%basetime%Sn,time%basetime%Sd - !PRINT *,'DEBUG: ESMF_TimePrint(): year = ',year - !PRINT *,'DEBUG: ESMF_TimePrint(): month, dayofmonth = ',month,dayofmonth - !PRINT *,'DEBUG: ESMF_TimePrint(): hour = ',hour - !PRINT *,'DEBUG: ESMF_TimePrint(): minute = ',minute - !PRINT *,'DEBUG: ESMF_TimePrint(): second = ',second - - !$$$here... add negative sign for YR<0 - !$$$here... add Sn, Sd ?? - write(TimeFormatString,FMT="(A,I4.4,A,I4.4,A)") & - "(I", yearWidth, ".", yearWidth, ",'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)" - write(TimeString,FMT=TimeFormatString) year,month,dayofmonth,hour,minute,second - - end subroutine ESMFold_TimeGetString - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeGetDayOfYearInteger - Get time instant's day of the year as an integer value - ! - ! !INTERFACE: - subroutine ESMF_TimeGetDayOfYearInteger(time, DayOfYear, rc) - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time - integer, intent(out) :: DayOfYear - integer, intent(out), optional :: rc - ! - ! !DESCRIPTION: - ! Get the day of the year the given {\tt ESMF\_Time} instant falls on - ! (1-365). Returned as an integer value - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! The object instance to query - ! \item[DayOfYear] - ! The {\tt ESMF\_Time} instant's day of the year (1-365) - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - !EOP - ! requires that time be normalized - !$$$ bug when Sn>0? test - !$$$ add tests - DayOfYear = ( time%basetime%S / SECONDS_PER_DAY ) + 1 - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - end subroutine ESMF_TimeGetDayOfYearInteger - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeInc - Increment time instant with a time interval - ! - ! !INTERFACE: - function ESMF_TimeInc(time, timeinterval) - ! - ! !RETURN VALUE: - type(ESMF_Time) :: ESMF_TimeInc - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time - type(ESMF_TimeInterval), intent(in) :: timeinterval - ! !LOCAL: - INTEGER :: year,month,day,sec,nmon,nyr,mpyi4 - ! - ! !DESCRIPTION: - ! Increment {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval}, - ! return resulting {\tt ESMF\_Time} instant - ! - ! Maps overloaded (+) operator interface function to - ! {\tt ESMF\_BaseTime} base class - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! The given {\tt ESMF\_Time} to increment - ! \item[timeinterval] - ! The {\tt ESMF\_TimeInterval} to add to the given {\tt ESMF\_Time} - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 - !EOP - - mpyi4 = MONTHS_PER_YEAR - - ! copy ESMF_Time specific properties (e.g. calendar, timezone) - - ESMF_TimeInc = time - ! write(6,*) 'tcx timeinc1 ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s - CALL normalize_time( ESMF_TimeInc ) - - ! write(6,*) 'tcx timeint ',timeinterval%yr,timeinterval%mm,timeinterval%basetime%s - - ! add years and months by manually forcing incremental years then adjusting the day of - ! the month at the end if it's greater than the number of days in the month - ! esmf seems to do exactly this based on testing - - nmon = timeinterval%mm - nyr = timeinterval%yr - if (abs(nmon) > 0 .or. abs(nyr) > 0) then - call ESMF_TimeGet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec) - ! write(6,*) 'tcx timeinc mon1 ',year,month,day,sec,nyr,nmon - year = year + nyr - month = month + nmon - do while (month > MONTHS_PER_YEAR) - month = month - mpyi4 - year = year + 1 - enddo - do while (month < 1) - month = month + mpyi4 - year = year - 1 - enddo - ! write(6,*) 'tcx timeinc mon2 ',year,month,day,sec - day = min(day,ndaysinmonth(year,month,ESMF_TimeInc%calendar%type)) - call ESMF_TimeSet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec,calkindflag=time%calendar%type) - call ESMF_TimeGet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec) - ! write(6,*) 'tcx timeinc mon3 ',nmon,year,month,day,sec - endif - - ! finally add seconds - - ! write(6,*) 'tcx timeinc sec ',ESMF_TimeInc%basetime%s,timeinterval%basetime%s - ESMF_TimeInc%basetime = ESMF_TimeInc%basetime + timeinterval%basetime - - ! and normalize - - ! write(6,*) 'tcx timeinc2p ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s - - CALL normalize_time( ESMF_TimeInc ) - - ! write(6,*) 'tcx timeinc2 ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s - - end function ESMF_TimeInc - - ! this is added for certain compilers that don't deal with commutativity - - function ESMF_TimeInc2(timeinterval, time) - type(ESMF_Time) :: ESMF_TimeInc2 - type(ESMF_Time), intent(in) :: time - type(ESMF_TimeInterval), intent(in) :: timeinterval - ESMF_TimeInc2 = ESMF_TimeInc( time, timeinterval ) - end function ESMF_TimeInc2 - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeDec - Decrement time instant with a time interval - ! - ! !INTERFACE: - function ESMF_TimeDec(time, timeinterval) - ! - ! !RETURN VALUE: - type(ESMF_Time) :: ESMF_TimeDec - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time - type(ESMF_TimeInterval), intent(in) :: timeinterval - ! !LOCAL: - TYPE (ESMF_TimeInterval) :: neginterval - - ! !DESCRIPTION: - ! Decrement {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval}, - ! return resulting {\tt ESMF\_Time} instant - ! - ! Maps overloaded (-) operator interface function to - ! {\tt ESMF\_BaseTime} base class - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! The given {\tt ESMF\_Time} to decrement - ! \item[timeinterval] - ! The {\tt ESMF\_TimeInterval} to subtract from the given - ! {\tt ESMF\_Time} - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 - !EOP - - ESMF_TimeDec = time - - neginterval = timeinterval - !$$$push this down into a unary negation operator on TimeInterval - neginterval%basetime%S = -neginterval%basetime%S - neginterval%basetime%Sn = -neginterval%basetime%Sn - neginterval%YR = -neginterval%YR - neginterval%MM = -neginterval%MM - ESMF_TimeDec = time + neginterval - - end function ESMF_TimeDec - - ! - ! this is added for certain compilers that don't deal with commutativity - ! - function ESMF_TimeDec2(timeinterval, time) - type(ESMF_Time) :: ESMF_TimeDec2 - type(ESMF_Time), intent(in) :: time - type(ESMF_TimeInterval), intent(in) :: timeinterval - ESMF_TimeDec2 = ESMF_TimeDec( time, timeinterval ) - end function ESMF_TimeDec2 - ! - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeDiff - Return the difference between two time instants - ! - ! !INTERFACE: - function ESMF_TimeDiff(time1, time2) - ! - ! !RETURN VALUE: - type(ESMF_TimeInterval) :: ESMF_TimeDiff - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - ! !LOCAL: - TYPE(ESMF_BaseTime) :: cmptime, zerotime - integer :: yr - integer :: y1,m1,d1,s1,y2,m2,d2,s2 - integer :: rc - - ! !DESCRIPTION: - ! Return the {\tt ESMF\_TimeInterval} difference between two - ! {\tt ESMF\_Time} instants, time1 - time2 - ! - ! Maps overloaded (-) operator interface function to - ! {\tt ESMF\_BaseTime} base class - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! The first {\tt ESMF\_Time} instant - ! \item[time2] - ! The second {\tt ESMF\_Time} instant - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 - !EOP - - CALL ESMF_TimeIntervalSet( ESMF_TimeDiff, rc=rc ) - - ESMF_TimeDiff%StartTime = time2 - ESMF_TimeDiff%StartTime_set = .true. - - ! write(6,*) 'tcx timediff1 ',time2%yr,time2%basetime%s,time2%calendar%type%caltype - ! write(6,*) 'tcx timediff2 ',time1%yr,time1%basetime%s,time1%calendar%type%caltype - - call ESMF_TimeGet(time2,yy=y2,mm=m2,dd=d2,s=s2) - call ESMF_TimeGet(time1,yy=y1,mm=m1,dd=d1,s=s1) - - ! Can either be yr/month based diff if diff is only in year and month - ! or absolute seconds if diff in day/seconds as well - ! - ! Update: Actually, the timeintcmp() routine in ESMF_TimeIntervalMod.F90 is not capable - ! of comparing time intervals when one interval has a different year and month than - ! the other. So, it is best here to always compute the interval as day/seconds. - - ! if (d1 == d2 .and. s1 == s2) then - !! write(6,*) 'tcx timedifft ym' - ! ESMF_TimeDiff%YR = y1 - y2 - ! ESMF_TimeDiff%MM = m1 - m2 - ! cmptime%S = 0 - ! cmptime%Sn = 0 - ! cmptime%Sd = 0 - ! ESMF_TimeDiff%basetime = cmptime - ! else - ! write(6,*) 'tcx timedifft sec' - ESMF_TimeDiff%YR = 0 - ESMF_TimeDiff%MM = 0 - ESMF_TimeDiff%basetime = time1%basetime - time2%basetime - IF ( time1%YR > time2%YR ) THEN - DO yr = time2%YR, ( time1%YR - 1 ) - ! write(6,*) 'tcx timediff3 ',yr,nsecondsinyear(yr,time2%calendar%type) - ESMF_TimeDiff%basetime%S = ESMF_TimeDiff%basetime%S + nsecondsinyear(yr,time2%calendar%type) - ENDDO - ELSE IF ( time2%YR > time1%YR ) THEN - DO yr = time1%YR, ( time2%YR - 1 ) - ! write(6,*) 'tcx timediff4 ',yr,nsecondsinyear(yr,time2%calendar%type) - ESMF_TimeDiff%basetime%S = ESMF_TimeDiff%basetime%S - nsecondsinyear(yr,time2%calendar%type) - ENDDO - ENDIF - ! endif - - ! write(6,*) 'tcx timediff5 ',ESMF_TimeDiff%YR, ESMF_TimeDiff%MM, ESMF_TimeDiff%basetime%s - - CALL normalize_timeint( ESMF_TimeDiff ) - - ! write(6,*) 'tcx timediff6 ',ESMF_TimeDiff%YR, ESMF_TimeDiff%MM, ESMF_TimeDiff%basetime%s - - end function ESMF_TimeDiff - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeEQ - Compare two times for equality - ! - ! !INTERFACE: - function ESMF_TimeEQ(time1, time2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeEQ - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - ! - ! !DESCRIPTION: - ! Return true if both given {\tt ESMF\_Time} instants are equal, false - ! otherwise. Maps overloaded (==) operator interface function to - ! {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! First time instant to compare - ! \item[time2] - ! Second time instant to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - integer :: res - - call timecmp(time1,time2,res) - ESMF_TimeEQ = (res .EQ. 0) - - end function ESMF_TimeEQ - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeNE - Compare two times for non-equality - ! - ! !INTERFACE: - function ESMF_TimeNE(time1, time2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeNE - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - - ! !DESCRIPTION: - ! Return true if both given {\tt ESMF\_Time} instants are not equal, false - ! otherwise. Maps overloaded (/=) operator interface function to - ! {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! First time instant to compare - ! \item[time2] - ! Second time instant to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - integer :: res - - call timecmp(time1,time2,res) - ESMF_TimeNE = (res .NE. 0) - - end function ESMF_TimeNE - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeLT - Time instant 1 less than time instant 2 ? - ! - ! !INTERFACE: - function ESMF_TimeLT(time1, time2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeLT - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - ! - ! !DESCRIPTION: - ! Return true if first {\tt ESMF\_Time} instant is less than second - ! {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (<) - ! operator interface function to {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! First time instant to compare - ! \item[time2] - ! Second time instant to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - integer :: res - - call timecmp(time1,time2,res) - ESMF_TimeLT = (res .LT. 0) - - end function ESMF_TimeLT - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeGT - Time instant 1 greater than time instant 2 ? - ! - ! !INTERFACE: - function ESMF_TimeGT(time1, time2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeGT - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - ! - ! !DESCRIPTION: - ! Return true if first {\tt ESMF\_Time} instant is greater than second - ! {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (>) operator - ! interface function to {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! First time instant to compare - ! \item[time2] - ! Second time instant to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - integer :: res - - call timecmp(time1,time2,res) - ESMF_TimeGT = (res .GT. 0) - - end function ESMF_TimeGT - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeLE - Time instant 1 less than or equal to time instant 2 ? - ! - ! !INTERFACE: - function ESMF_TimeLE(time1, time2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeLE - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - ! - ! !DESCRIPTION: - ! Return true if first {\tt ESMF\_Time} instant is less than or equal to - ! second {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (<=) - ! operator interface function to {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! First time instant to compare - ! \item[time2] - ! Second time instant to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - integer :: res - - call timecmp(time1,time2,res) - ESMF_TimeLE = (res .LE. 0) - - end function ESMF_TimeLE - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeGE - Time instant 1 greater than or equal to time instant 2 ? - ! - ! !INTERFACE: - function ESMF_TimeGE(time1, time2) - ! - ! !RETURN VALUE: - logical :: ESMF_TimeGE - ! - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - ! - ! !DESCRIPTION: - ! Return true if first {\tt ESMF\_Time} instant is greater than or equal to - ! second {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (>=) - ! operator interface function to {\tt ESMF\_BaseTime} base class. - ! - ! The arguments are: - ! \begin{description} - ! \item[time1] - ! First time instant to compare - ! \item[time2] - ! Second time instant to compare - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMG1.5.3, TMG2.4.3, TMG7.2 - !EOP - - integer :: res - - call timecmp(time1,time2,res) - ESMF_TimeGE = (res .GE. 0) - - end function ESMF_TimeGE - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimeCopy - Copy a time-instance - - ! !INTERFACE: - subroutine ESMF_TimeCopy(timeout, timein) - - ! !ARGUMENTS: - type(ESMF_Time), intent(out) :: timeout - type(ESMF_Time), intent(in) :: timein - - ! !DESCRIPTION: - ! Copy a time-instance to a new instance. - ! - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - - timeout%basetime = timein%basetime - timeout%YR = timein%YR - timeout%Calendar => timein%Calendar - !tcx timeout%Calendar = timein%Calendar - ! write(6,*) 'tcxa ESMF_TimeCopy' - ! call flush(6) - ! write(6,*) 'tcxb ESMF_TimeCopy',timein%calendar%type%caltype - ! call flush(6) - timeout%Calendar = ESMF_CalendarCreate(calkindflag=timein%calendar%type) - - end subroutine ESMF_TimeCopy - - - !------------------------------------------------------------------------------ - !BOP - ! !IROUTINE: ESMF_TimePrint - Print out a time instant's properties - - - ! !INTERFACE: - subroutine ESMF_TimePrint(time, options, rc) - - ! !ARGUMENTS: - type(ESMF_Time), intent(in) :: time - character (len=*), intent(in), optional :: options - integer, intent(out), optional :: rc - character (len=256) :: timestr - - ! !DESCRIPTION: - ! To support testing/debugging, print out a {\tt ESMF\_Time}'s - ! properties. - ! - ! The arguments are: - ! \begin{description} - ! \item[time] - ! {\tt ESMF\_Time} instant to print out - ! \item[{[options]}] - ! Print options - ! \item[{[rc]}] - ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. - ! \end{description} - ! - ! !REQUIREMENTS: - ! TMGn.n.n - !EOP - - ! Quick hack to mimic ESMF 2.0.1 - ! Really should check value of options... - IF ( PRESENT( options ) ) THEN - CALL ESMF_TimeGet( time, timeString=timestr, rc=rc ) - timestr(11:11) = 'T' ! ISO 8601 compatibility hack for debugging - print *,' Time -----------------------------------' - print *,' ',TRIM(timestr) - print *,' end Time -------------------------------' - print * - ELSE - call print_a_time (time) - ENDIF - - end subroutine ESMF_TimePrint - - !============================================================================== - - SUBROUTINE print_a_time( time ) - IMPLICIT NONE - type(ESMF_Time) time - character*128 :: s - integer rc - CALL ESMF_TimeGet( time, timeString=s, rc=rc ) - print *,'Print a time|',TRIM(s),'|' - write(0,*)'Print a time|',TRIM(s),'|' - return - END SUBROUTINE print_a_time - - !============================================================================== - - SUBROUTINE timecmp(time1, time2, retval ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval - ! - ! !ARGUMENTS: - TYPE(ESMF_Time), INTENT(IN) :: time1 - TYPE(ESMF_Time), INTENT(IN) :: time2 - IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF - IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF - CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, & - time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, & - retval ) - END SUBROUTINE timecmp - - !============================================================================== - - SUBROUTINE normalize_time( time ) - ! A normalized time has time%basetime >= 0, time%basetime less than the current - ! year expressed as a timeInterval, and time%YR can take any value - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(INOUT) :: time - ! INTEGER(ESMF_KIND_I8) :: nsecondsinyear - ! locals - TYPE(ESMF_BaseTime) :: cmptime, zerotime - INTEGER :: rc - LOGICAL :: done - - ! first, normalize basetime - ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match - - CALL normalize_basetime( time%basetime ) - - ! next, underflow negative seconds into YEARS - ! time%basetime must end up non-negative - - zerotime%S = 0 - zerotime%Sn = 0 - zerotime%Sd = 0 - DO WHILE ( time%basetime < zerotime ) - time%YR = time%YR - 1 - cmptime%S = nsecondsinyear( time%YR, time%calendar%type ) - cmptime%Sn = 0 - cmptime%Sd = 0 - time%basetime = time%basetime + cmptime - ENDDO - - ! next, overflow seconds into YEARS - done = .FALSE. - DO WHILE ( .NOT. done ) - cmptime%S = nsecondsinyear( time%YR, time%calendar%type ) - cmptime%Sn = 0 - cmptime%Sd = 0 - IF ( time%basetime >= cmptime ) THEN - time%basetime = time%basetime - cmptime - time%YR = time%YR + 1 - ELSE - done = .TRUE. - ENDIF - ENDDO - - END SUBROUTINE normalize_time - - !============================================================================== - - SUBROUTINE timegetmonth( time, MM ) - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time - INTEGER, INTENT(OUT) :: MM - ! locals - - mm = nmonthinyearsec(time%yr,time%basetime,time%calendar%type) - - END SUBROUTINE timegetmonth - - !============================================================================== - SUBROUTINE timegetdayofmonth( time, DD ) - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time - INTEGER, INTENT(OUT) :: DD - ! locals - - dd = ndayinyearsec(time%yr, time%basetime, time%calendar%type) - - END SUBROUTINE timegetdayofmonth - - !============================================================================== - - ! Increment Time by number of seconds between start of year and start - ! of month MM. - ! 1 <= MM <= 12 - ! Time is NOT normalized. - SUBROUTINE timeaddmonths( time, MM, ierr ) - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(INOUT) :: time - INTEGER, INTENT(IN) :: MM - INTEGER, INTENT(OUT) :: ierr - ! locals - INTEGER(ESMF_KIND_I8) :: isec - - ierr = ESMF_SUCCESS - IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN - CALL wrf_message( 'ERROR timeaddmonths(): MM out of range' ) - ierr = ESMF_FAILURE - return - ENDIF - - isec = nsecondsinyearmonth(time%yr,MM,time%calendar%type) - time%basetime%s = time%basetime%s + isec - - END SUBROUTINE timeaddmonths - - !============================================================================== - - ! Increment Time by number of seconds between start of year and start - ! of month MM. - ! 1 <= MM <= 12 - ! Time is NOT normalized. - SUBROUTINE ESMF_setYearWidth( yearWidthIn ) - - integer, intent(in) :: yearWidthIn - - yearWidth = yearWidthIn - - END SUBROUTINE ESMF_setYearWidth - - !============================================================================== - !============================================================================== - end module ESMF_TimeMod diff --git a/src/esmf_wrf_timemgr/Makefile b/src/esmf_wrf_timemgr/Makefile deleted file mode 100644 index d2e6129..0000000 --- a/src/esmf_wrf_timemgr/Makefile +++ /dev/null @@ -1,60 +0,0 @@ -.SUFFIXES: .F90 .o - -OBJS = ESMF_AlarmClockMod.o \ - ESMF_AlarmMod.o \ - ESMF_BaseMod.o \ - ESMF_BaseTimeMod.o \ - ESMF_CalendarMod.o \ - ESMF_ClockMod.o \ - ESMF.o \ - ESMF_FractionMod.o \ - ESMF_ShrTimeMod.o \ - ESMF_Stubs.o \ - ESMF_TimeIntervalMod.o \ - ESMF_TimeMod.o \ - MeatMod.o \ - wrf_error_fatal.o \ - wrf_message.o - -all: $(OBJS) - ar -ru libesmf_time.a *.o - -ESMF_AlarmClockMod.o: ESMF_AlarmMod.o ESMF_ClockMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o - -ESMF_AlarmMod.o: ESMF_BaseMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o - -ESMF_BaseMod.o: - -ESMF_BaseTimeMod.o: ESMF_BaseMod.o - -ESMF_CalendarMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o - -ESMF_ClockMod.o: ESMF_BaseMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o ESMF_AlarmMod.o ESMF_TimeMod.o - -ESMF.o: ESMF_AlarmMod.o ESMF_BaseMod.o ESMF_BaseTimeMod.o \ - ESMF_CalendarMod.o ESMF_ClockMod.o ESMF_FractionMod.o \ - ESMF_TimeIntervalMod.o ESMF_TimeMod.o ESMF_ShrTimeMod.o \ - ESMF_AlarmClockMod.o ESMF_Stubs.o MeatMod.o - -ESMF_FractionMod.o: - -ESMF_ShrTimeMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_CalendarMod.o - -ESMF_Stubs.o: ESMF_BaseMod.o ESMF_CalendarMod.o - -ESMF_TimeIntervalMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_FractionMod.o ESMF_CalendarMod.o ESMF_ShrTimeMod.o - -ESMF_TimeMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_TimeIntervalMod.o ESMF_CalendarMod.o ESMF_ShrTimeMod.o ESMF_Stubs.o - -MeatMod.o: ESMF_BaseMod.o - -wrf_error_fatal.o: - -wrf_message.o: - -clean: - rm -rf *.o *.mod *.a - -.F90.o: - $(RM) $@ $*.mod - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. diff --git a/src/esmf_wrf_timemgr/MeatMod.F90 b/src/esmf_wrf_timemgr/MeatMod.F90 deleted file mode 100644 index dcae37f..0000000 --- a/src/esmf_wrf_timemgr/MeatMod.F90 +++ /dev/null @@ -1,65 +0,0 @@ -module MeatMod - -#include - - use ESMF_BaseMod - - implicit none - - private - - public fraction_to_stringi8 - public fraction_to_string - - !============================================================================== -contains - !============================================================================== - - !============================================================================== - - !============================================================================== - ! Convert fraction to string with leading sign. - ! If fraction simplifies to a whole number or if - ! denominator is zero, return empty string. - ! INTEGER*8 interface. - SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str ) - IMPLICIT NONE - INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator - INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator - CHARACTER (LEN=*), INTENT(OUT) :: frac_str - IF ( denominator > 0 ) THEN - IF ( mod( numerator, denominator ) /= 0 ) THEN - IF ( numerator > 0 ) THEN - WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator - ELSE ! numerator < 0 - WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator - ENDIF - ELSE ! includes numerator == 0 case - frac_str = '' - ENDIF - ELSE ! no-fraction case - frac_str = '' - ENDIF - END SUBROUTINE fraction_to_stringi8 - - !============================================================================== - - ! Convert fraction to string with leading sign. - ! If fraction simplifies to a whole number or if - ! denominator is zero, return empty string. - ! INTEGER interface. - SUBROUTINE fraction_to_string( numerator, denominator, frac_str ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: numerator - INTEGER, INTENT(IN) :: denominator - CHARACTER (LEN=*), INTENT(OUT) :: frac_str - ! locals - INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8 - numerator_i8 = INT( numerator, ESMF_KIND_I8 ) - denominator_i8 = INT( denominator, ESMF_KIND_I8 ) - CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str ) - END SUBROUTINE fraction_to_string - - !============================================================================== - -end module MeatMod diff --git a/src/esmf_wrf_timemgr/README b/src/esmf_wrf_timemgr/README deleted file mode 100644 index e8c73ef..0000000 --- a/src/esmf_wrf_timemgr/README +++ /dev/null @@ -1,19 +0,0 @@ - -Quick README -Tony Craig, Feb, 2012 - -This is a partial substitute for the ESMF Time Manager. As of Feb, 2012, -what exists is consist (in interfaces and datatypes) with ESMF 5.2.0rp1. -The datatypes in this version are not interchangable with ESMF nor will the -answers be exactly identical. - -This version supports the NOLEAP and GREGORIAN calendar. It also supports -use of the D and Dl interfaces in ESMF_TimeSet and ESMF_TimeGet. The julian -day reference is that day 1 is year 0, month 1, day 1 (0000-01-01 or Jan 1, 0000). -It also supports positive or negative years. - -Several aspects of the ESMF interfaces are not supported. - -There is a unit tester that tests ESMF_Time and ESMF_TimeInterval actions -for both gregorian and noleap calendar. - diff --git a/src/esmf_wrf_timemgr/unittests/Makefile b/src/esmf_wrf_timemgr/unittests/Makefile deleted file mode 100644 index 874a0b4..0000000 --- a/src/esmf_wrf_timemgr/unittests/Makefile +++ /dev/null @@ -1,63 +0,0 @@ - -cpp_dirs := . .. -cpp_path := $(foreach dir,$(cpp_dirs),-I$(dir)) # format for command line -# Expand any tildes in directory names. Change spaces to colons. -VPATH := $(foreach dir,$(cpp_dirs),$(wildcard $(dir))) -VPATH := $(subst $(space),:,$(VPATH)) - -#VPATH := .:.. - - -.SUFFIXES: .F90 .o .F .f90 - -AR := ar -FC := xlf95 -FFLAGS := -g -qfullpath -qmaxmem=-1 -O2 -qstrict -qsigtrap=xl__trcedump -Q -qinitauto=7FF7FFFF -qflttrap=ov:zero:inv:en -qspillsize=4000 -qarch=auto -qtune=auto -qsuffix=f=f90:cpp=F90 -I. -I.. -WF,-DHIDE_MPI -LDFLAGS := - -OBJS := ESMF_AlarmMod.o ESMF_BaseTimeMod.o ESMF_ClockMod.o ESMF_TimeMod.o \ - MeatMod.o ESMF_BaseMod.o ESMF_CalendarMod.o ESMF_FractionMod.o \ - ESMF_TimeIntervalMod.o ESMF_Stubs.o ESMF.o ESMF_ShrTimeMod.o \ - ESMF_AlarmClockMod.o wrf_stuff.o - -test: libesmf_time.a test.o - $(FC) $(LDFLAGS) -o test test.o -L. -lesmf_time - -lib: libesmf_time.a - -debug: $(OBJS) - echo "VPATH : $VPATH" - echo "OBJS : $OBJ" - echo "FFLAGS: $FFLAGS" - -libesmf_time.a : $(OBJS) - \rm -f libesmf_time.a - $(AR) $(ARFLAGS) libesmf_time.a $(OBJS) - -.F90.o : - $(FC) -c $(FFLAGS) $< - -clean: - /bin/rm -f *.o libesmf_time.a *.mod test - -# DEPENDENCIES : only dependencies after this line - -#$$$ update dependencies! - -ESMF_BaseMod.o : ESMF_BaseMod.F90 wrf_stuff.o -ESMF_FractionMod.o: ESMF_FractionMod.F90 -MeatMod.o : MeatMod.F90 ESMF_BaseMod.o -ESMF_BaseTimeMod.o : ESMF_BaseTimeMod.F90 ESMF_BaseMod.o -ESMF_CalendarMod.o : ESMF_CalendarMod.F90 ESMF_BaseMod.o ESMF_BaseTimeMod.o -ESMF_Stubs.o : ESMF_Stubs.F90 ESMF_CalendarMod.o ESMF_BaseMod.o -ESMF_ShrTimeMod.o : ESMF_ShrTimeMod.F90 ESMF_CalendarMod.o ESMF_BaseTimeMod.o ESMF_BaseMod.o -ESMF_TimeIntervalMod.o : ESMF_TimeIntervalMod.F90 ESMF_FractionMod.o -ESMF_TimeMod.o : ESMF_TimeMod.F90 ESMF_ShrTimeMod.o ESMF_Stubs.o ESMF_TimeIntervalMod.o -ESMF_AlarmMod.o : ESMF_AlarmMod.F90 ESMF_BaseTimeMod.o ESMF_TimeMod.o ESMF_TimeIntervalMod.o -ESMF_ClockMod.o : ESMF_ClockMod.F90 ESMF_BaseTimeMod.o ESMF_TimeMod.o ESMF_TimeIntervalMod.o ESMF_AlarmMod.o -ESMF_AlarmClockMod.o : ESMF_AlarmClockMod.F90 ESMF_AlarmMod.o ESMF_ClockMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o -ESMF.o : ESMF.F90 ESMF_AlarmMod.o ESMF_BaseTimeMod.o ESMF_ClockMod.o ESMF_TimeMod.o \ - ESMF_BaseMod.o ESMF_CalendarMod.o ESMF_FractionMod.o ESMF_ShrTimeMod.o \ - ESMF_TimeIntervalMod.o ESMF_Stubs.o ESMF_AlarmClockMod.o -test.o : test.F90 ESMF.o - diff --git a/src/esmf_wrf_timemgr/unittests/go.csh b/src/esmf_wrf_timemgr/unittests/go.csh deleted file mode 100755 index 77641ff..0000000 --- a/src/esmf_wrf_timemgr/unittests/go.csh +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/csh - -rm -f ./test -gmake -rm -f ./test.out -./test >& test.out - -tail -5 test.out -set nd = `diff test.out.base test.out | wc -l` - -echo "diffs vs baseline = $nd" - - - diff --git a/src/esmf_wrf_timemgr/unittests/test.F90 b/src/esmf_wrf_timemgr/unittests/test.F90 deleted file mode 100644 index e94ded9..0000000 --- a/src/esmf_wrf_timemgr/unittests/test.F90 +++ /dev/null @@ -1,312 +0,0 @@ - - program test - - use esmf - - implicit none - - type(ESMF_Time) :: time1,time2,time3,time4,time5,time6,time7,time8 - type(ESMF_TimeInterval) :: timeint1,timeint2,timeint3,timeint4,timeint5 - type(ESMF_Calkind_Flag) :: calkindflag - - integer :: year,month,day,hour,min,sec,jday - integer :: year1,month1,day1,hour1,min1,sec1,jday1 - integer :: year2,month2,day2,hour2,min2,sec2,jday2 - integer :: iyear,imonth,iday,ihour,imin,isec - integer :: dyear,dmonth,dday,dhour,dmin,dsec - integer :: icyear,icmonth,icday,ichour,icmin,icsec - integer :: ical,i1,i2,delta - integer :: errcnt, totcnt - logical :: errfound - character(len=8) :: dstr,calstr - character(len=32) :: estr1,estr2 - - INTEGER, PARAMETER :: mday(12) & - = (/31,28,31,30,31,30,31,31,30,31,30,31/) - INTEGER, PARAMETER :: mdayleap(12) & - = (/31,29,31,30,31,30,31,31,30,31,30,31/) - - character(len=*),parameter :: F01 = "(2x,a,1x,a6,i6,'-',i2.2,'-',i2.2,1x,i2.2,':',i2.2,':',i2.2,1x,a8,i12,a8,i6)" - character(len=*),parameter :: F02 = "(a,1x,a6,2x,i6,'-',i2.2,'-',i2.2,1x,i2.2,':',i2.2,':',i2.2,1x,a8,i12)" - character(len=*),parameter :: F03 = "(a,1x,i6,'-',i2.2,'-',i2.2,1x,a8,a8,i12)" - - call ESMF_Initialize() - - totcnt = 0 - errcnt = 0 - - do icyear = 1,8 - do icmonth = 1,12 - do icday = 1,4 - do ichour = 2,2 - do icmin = 30,30 - do icsec = 10,10 - do ical = 1,2 - - write(6,*) ' ' - write(estr1,'(i2.2,i2.2,i2.2,i2.2,i2.2,i2.2,i2.2)') icyear,icmonth,icday,ichour,icmin,icsec,ical - - if (icyear == 1) iyear = 0 - if (icyear == 2) iyear = 1 - if (icyear == 3) iyear = 1900 - if (icyear == 4) iyear = 1995 - if (icyear == 5) iyear = 1996 - if (icyear == 6) iyear = 2000 - if (icyear == 7) iyear = 9900 - if (icyear == 8) iyear = 9999 - - imonth = icmonth - - if (icday == 1) iday = 1 - if (icday == 2) iday = 20 - if (icday == 3) iday = mday(imonth)-1 - if (icday == 4) iday = mday(imonth) - - ihour = ichour - - imin = icmin - - isec = icsec - - if (ical == 1) then - calstr = 'noleap' - calkindflag = ESMF_CALKIND_NOLEAP - endif - if (ical == 2) then - calstr = 'gregor' - calkindflag = ESMF_CALKIND_GREGORIAN - endif - - write(6,F02) trim(estr1),'jd0 ',iyear,imonth,iday,ihour,imin,isec,trim(calstr) - - call ESMF_TimeSet(time1,yy=iyear,mm=imonth,dd=iday,h=ihour,m=imin,s=isec,calkindflag=calkindflag) - - call ESMF_TimeGet(time1,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time1,d=jday) - write(6,F02) trim(estr1),'jd1 ',year,month,day,hour,min,sec,trim(calstr),jday - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeSet(time2,d=jday,calkindflag=calkindflag) - call ESMF_TimeGet(time2,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time2,d=jday) - write(6,F02) trim(estr1),'jd2 ',year,month,day,hour,min,sec,trim(calstr),jday - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - if (year /= iyear .or. month /= imonth .or. day /= iday) then - call wrf_error_fatal('ERROR: jday conversion') - endif - - do i1 = 1,7 - do i2 = 1,4 - write(6,*) ' ' - write(estr2,'(a,i2.2,i2.2)') trim(estr1),i1,i2 - - if (i2 == 1) delta = 1 - if (i2 == 2) delta = -1 - if (i2 == 3) delta = 150 - if (i2 == 4) delta = -150 - - dyear = 0 - dmonth = 0 - dday = 0 - dhour =0 - dmin = 0 - dsec = 0 - - if (i1 == 1) then - dstr = 'year' - dyear = delta - endif - if (i1 == 2) then - dstr = 'month' - dmonth = delta - endif - if (i1 == 3) then - dstr = 'day' - dday = delta - endif - if (i1 == 4) then - dstr = 'hour' - dhour = delta - endif - if (i1 == 5) then - dstr = 'min' - dmin = delta - endif - if (i1 == 6) then - dstr = 'sec' - dsec = delta - endif - if (i1 == 7) then - dstr = 'all' - dyear = delta - dmonth = delta - dday = delta - dhour = delta - dmin = delta - dsec = delta - endif - - call ESMF_TimeIntervalSet(timeint1,yy= dyear,mm= dmonth,d= dday,h= dhour,m= dmin,s= dsec) - call ESMF_TimeIntervalSet(timeint2,yy=2*dyear,mm=2*dmonth,d=2*dday,h=2*dhour,m=2*dmin,s=2*dsec) - call ESMF_TimeIntervalSet(timeint3,yy=-dyear,mm=-dmonth,d=-dday,h=-dhour,m=-dmin,s=-dsec) - - !time1 = ! zero - time2 = time1 + timeint1 ! + delta - timeint4 = time2 - time1 ! this should be same as timeint1 but only for time2-time1 - time3 = time2 - timeint4 ! zero - time4 = time3 + timeint2 ! + 2*delta - time5 = time4 - timeint1 ! + delta - time6 = time5 + timeint3 ! zero - time7 = time6 + timeint3 ! - delta - time8 = time7 - timeint3 ! zero - - call ESMF_TimeGet(time1,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time1,d=jday) - write(6,F01) trim(estr2),'ti1 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time2,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time2,d=jday) - write(6,F01) trim(estr2),'ti2 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time3,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time3,d=jday) - write(6,F01) trim(estr2),'ti3 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time4,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time4,d=jday) - write(6,F01) trim(estr2),'ti4 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time5,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time5,d=jday) - write(6,F01) trim(estr2),'ti5 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time6,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time6,d=jday) - write(6,F01) trim(estr2),'ti6 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time7,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time7,d=jday) - write(6,F01) trim(estr2),'ti7 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time8,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) - call ESMF_TimeGet(time8,d=jday) - write(6,F01) trim(estr2),'ti8 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta - call checkdate(year,month,day,hour,min,sec,trim(calstr)) - - call ESMF_TimeGet(time1,yy=year1,mm=month1,dd=day1,h=hour1,m=min1,s=sec1) - call ESMF_TimeGet(time1,d=jday1) - call ESMF_TimeGet(time8,yy=year2,mm=month2,dd=day2,h=hour2,m=min2,s=sec2) - call ESMF_TimeGet(time8,d=jday2) - - totcnt = totcnt + 1 - errfound = .false. - - if (time1 /= time3) then - if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then - write(6,F03) 'ERROR: timediff non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta - if (.not. errfound) errcnt = errcnt + 1 - errfound = .true. - else - call wrf_error_fatal('ERROR: timeinc time') - endif - endif - - if (time3 /= time6) then - if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then - write(6,F03) 'ERROR: time2x non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta - if (.not. errfound) errcnt = errcnt + 1 - errfound = .true. - else - call wrf_error_fatal('ERROR: timeinc time') - endif - endif - - if (time6 /= time8) then - if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then - write(6,F03) 'ERROR: timeneg non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta - if (.not. errfound) errcnt = errcnt + 1 - errfound = .true. - else - call wrf_error_fatal('ERROR: timeinc time') - endif - endif - - if (time2 /= time5) then - if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then - write(6,F03) 'ERROR: timecomp non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta - if (.not. errfound) errcnt = errcnt + 1 - errfound = .true. - else - call wrf_error_fatal('ERROR: timeinc time') - endif - endif - - if (year1 /= year2 .or. month1 /= month2 .or. day1 /= day2 .or. & - hour1 /= hour2 .or. min1 /= min2 .or. sec1 /= sec2 .or. jday1 /= jday2) then - if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then - write(6,F03) 'ERROR: ymdhms non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta - if (.not. errfound) errcnt = errcnt + 1 - errfound = .true. - else - call wrf_error_fatal('ERROR: timeinc ymdhms') - endif - endif - - enddo - enddo - - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - write(6,*) ' ' - write(6,*) 'tests run = ',totcnt,' error tests = ',errcnt - write(6,*) 'esmf_wrf_timemgr test program completed successfully ' - write(6,*) ' ' - - end program test - - - subroutine checkdate(year,month,day,hour,min,sec,calstr) - - implicit none - integer, intent(in) :: year,month,day,hour,min,sec - character(len=*),intent(in) :: calstr - INTEGER, PARAMETER :: mday(12) & - = (/31,28,31,30,31,30,31,31,30,31,30,31/) - INTEGER, PARAMETER :: mdayleap(12) & - = (/31,29,31,30,31,30,31,31,30,31,30,31/) - logical :: error - - error = .false. - - if (month < 1 .or. month > 12) error = .true. - if (trim(calstr) == 'noleap') then - if (day < 1 .or. day > mday(month)) error = .true. - elseif (trim(calstr) == 'gregor') then - if (day < 1 .or. day > mdayleap(month)) error = .true. - else - error = .true. - endif - if (hour < 0 .or. hour > 23) error = .true. - if (min < 0 .or. min > 59) error = .true. - if (sec < 0 .or. sec > 59) error = .true. - - if (error) then - write(6,*) 'ERROR checkdate ',year,month,day,hour,min,sec,trim(calstr) - call wrf_error_fatal('ERROR: checkdate') - endif - - end subroutine checkdate diff --git a/src/esmf_wrf_timemgr/unittests/wrf_stuff.F90 b/src/esmf_wrf_timemgr/unittests/wrf_stuff.F90 deleted file mode 100644 index c723ae2..0000000 --- a/src/esmf_wrf_timemgr/unittests/wrf_stuff.F90 +++ /dev/null @@ -1,17 +0,0 @@ - -SUBROUTINE wrf_message( str ) - IMPLICIT NONE - CHARACTER*(*) str - write(6,*) 'wrf_message ',trim(str) -END SUBROUTINE wrf_message - - -SUBROUTINE wrf_error_fatal( str ) - IMPLICIT NONE - CHARACTER*(*) str - write(6,*) 'wrf_error_fatal ',trim(str) - stop -END SUBROUTINE wrf_error_fatal - - - diff --git a/src/esmf_wrf_timemgr/wrf_error_fatal.F90 b/src/esmf_wrf_timemgr/wrf_error_fatal.F90 deleted file mode 100644 index e7b0ee6..0000000 --- a/src/esmf_wrf_timemgr/wrf_error_fatal.F90 +++ /dev/null @@ -1,9 +0,0 @@ - -subroutine wrf_error_fatal(msg) - use shr_sys_mod, only: shr_sys_abort - implicit none - character(len=*), intent(in) :: msg - write(6,*) 'wrf_error_fatal: ',trim(msg) - call shr_sys_abort( msg ) -end subroutine wrf_error_fatal - diff --git a/src/esmf_wrf_timemgr/wrf_message.F90 b/src/esmf_wrf_timemgr/wrf_message.F90 deleted file mode 100644 index 1bec99c..0000000 --- a/src/esmf_wrf_timemgr/wrf_message.F90 +++ /dev/null @@ -1,5 +0,0 @@ -SUBROUTINE wrf_message( str ) - IMPLICIT NONE - CHARACTER*(*) str - write(6,*) str -END SUBROUTINE wrf_message diff --git a/test/old_unit_testers/Makefile b/test/old_unit_testers/Makefile deleted file mode 100644 index 7706964..0000000 --- a/test/old_unit_testers/Makefile +++ /dev/null @@ -1,163 +0,0 @@ -#----------------------------------------------------------------------- -# This Makefile is for doing csm_share unit testing -#------------------------------------------------------------------------ -cpp_dirs := . ../shr ../../utils/mct/mct \ - ../../utils/mct/mpeu ../../utils/esmf_wrf_timemgr ../../utils/timing \ - ../../drv/shr -ifneq ($(SPMD),TRUE) -cpp_dirs += ../../utils/mct/mpi-serial -endif -cpp_dirs += ../../utils/pio -cpp_path := $(foreach dir,$(cpp_dirs),-I$(dir)) # format for command line - -# Platform specific macros -include make.Macros - -space := $(null) $(null) - -ifneq ($(ESMF_BLD),$(null)) -cpp_dirs += $(ESMF_LIB) -endif - -# Expand any tildes in directory names. -VPATH := $(foreach dir,$(cpp_dirs),$(wildcard $(dir))) -# Change spaces to colons. -VPATH := $(subst $(space),:,$(VPATH)) - -.PHONY: debug clean all - -all: test_shr_tInterp - - -ifneq ($(SPMD),TRUE) - OBJS_NOMPI := fort.o group.o collective.o comm.o list.o handles.o mpi.o recv.o req.o \ - send.o time.o -$(OBJS_NOMPI) shr_mpi_mod.o: mpif.h -mpif.h: - ln -s ../../utils/mct/mpi-serial/mpif.real4double8.h $@ -else - OBJS_NOMPI := $(null) -endif -OBJS_MCT := m_Accumulator.o m_AccumulatorComms.o m_AttrVect.o m_AttrVectComms.o \ - m_AttrVectReduce.o m_ConvertMaps.o m_ExchangeMaps.o m_GeneralGrid.o \ - m_GeneralGridComms.o m_GlobalMap.o m_GlobalSegMap.o \ - m_GlobalSegMapComms.o m_GlobalToLocal.o m_MCTWorld.o m_MatAttrVectMul.o \ - m_Merge.o m_Navigator.o m_Rearranger.o m_Router.o m_SparseMatrix.o \ - m_SparseMatrixComms.o m_SparseMatrixDecomp.o m_SparseMatrixPlus.o \ - m_SparseMatrixToMaps.o m_SpatialIntegral.o m_SpatialIntegralV.o \ - m_Transfer.o \ - m_FcComms.o m_FileResolv.o m_Filename.o m_IndexBin_char.o \ - m_IndexBin_integer.o m_IndexBin_logical.o m_List.o m_MergeSorts.o \ - m_Permuter.o m_SortingTools.o m_StrTemplate.o m_String.o m_TraceBack.o \ - m_chars.o m_die.o m_dropdead.o m_flow.o m_inpak90.o m_ioutil.o m_mall.o \ - m_mpif.o m_mpif90.o m_mpout.o m_rankMerge.o m_realkinds.o m_stdio.o \ - m_zeit.o get_zeits.o -OBJS_PIO := alloc_mod.o box_rearrange.o calcdisplace_mod.o iompi_mod.o \ - ionf_mod.o \ - nf_mod.o pio.o pio_kinds.o pio_mpi_utils.o pio_nf_utils.o \ - pio_msg_callbacks.o pio_msg_getput_callbacks.o pio_msg_mod.o \ - pio_nf_utils.o pio_quicksort.o pio_spmd_utils.o pio_support.o pio_types.o \ - pio_utils.o piodarray.o piolib_mod.o pionfatt_mod.o \ - pionfget_mod.o pionfput_mod.o pionfread_mod.o pionfwrite_mod.o \ - rearrange.o -OBJS_TIM := perf_mod.o perf_utils.o GPTLget_memusage.o GPTLprint_memusage.o \ - GPTLutil.o f_wrappers.o gptl.o gptl_papi.o threadutil.o - -OBJS := test_shr_sys.o shr_sys_mod.o shr_kind_mod.o shr_mpi_mod.o shr_const_mod.o shr_log_mod.o \ - $(OBJS_NOMPI) -OBJS_FILE := test_shr_file.o shr_sys_mod.o shr_kind_mod.o shr_file_mod.o shr_mpi_mod.o shr_log_mod.o \ - $(OBJS_NOMPI) -OBJS_ORB := test_shr_orb.o shr_sys_mod.o shr_kind_mod.o shr_orb_mod.o shr_mpi_mod.o shr_log_mod.o \ - shr_const_mod.o $(OBJS_NOMPI) -OBJS_STRMS := test_shr_streams.o shr_kind_mod.o shr_stream_mod.o shr_sys_mod.o \ - shr_file_mod.o shr_string_mod.o shr_timer_mod.o shr_mpi_mod.o \ - shr_cal_mod.o shr_ncread_mod.o shr_const_mod.o \ - shr_log_mod.o test_mod.o $(OBJS_NOMPI) -OBJS_SCAM := test_shr_scam.o shr_strdata_mod.o shr_const_mod.o shr_kind_mod.o \ - shr_log_mod.o shr_sys_mod.o shr_file_mod.o shr_stream_mod.o \ - shr_map_mod.o shr_string_mod.o shr_cal_mod.o shr_orb_mod.o \ - shr_tinterp_mod.o shr_dmodel_mod.o shr_mct_mod.o mct_mod.o \ - perf_mod.o pio.o shr_mpi_mod.o seq_flds_mod.o shr_ncread_mod.o \ - shr_scam_mod.o shr_pcdf_mod.o shr_mct_mod.o mct_mod.o shr_timer_mod.o \ - seq_drydep_mod.o test_mod.o \ - $(OBJS_NOMPI) $(OBJS_MCT) $(OBJS_PIO) $(OBJS_TIM) -OBJS_STIN := test_shr_tInterp.o shr_kind_mod.o shr_const_mod.o shr_sys_mod.o \ - shr_string_mod.o shr_cal_mod.o shr_log_mod.o shr_orb_mod.o test_mod.o \ - shr_tInterp_mod.o shr_timer_mod.o shr_mpi_mod.o $(OBJS_NOMPI) -OBJS_MPI := test_shr_mpi.o shr_mpi_mod.o shr_kind_mod.o shr_sys_mod.o shr_const_mod.o shr_log_mod.o $(OBJS_NOMPI) - -OBJS_LOG := test_shr_log.o shr_log_mod.o shr_kind_mod.o \ - test_mod.o shr_sys_mod.o shr_mpi_mod.o $(OBJS_NOMPI) - -WRFESMF_OBJS := ESMF_AlarmMod.o ESMF_BaseTimeMod.o ESMF_ClockMod.o ESMF_TimeMod.o \ - Meat.o ESMF_BaseMod.o ESMF_CalendarMod.o ESMF_FractionMod.o \ - ESMF_TimeIntervalMod.o ESMF_Stubs.o ESMF_Mod.o \ - ESMF_AlarmClockMod.o wrf_error_fatal.o wrf_message.o - -ifeq ($(ESMF_BLD),$(null)) - OBJS_STIN += $(WRFESMF_OBJS) - OBJS_STRMS += $(WRFESMF_OBJS) - OBJS_SCAM += $(WRFESMF_OBJS) -endif - -# -# Executables: -# - -debug: - @echo "VPATH: " $(VPATH) - @echo "ESMF_MOD: " $(ESMF_MOD) - @echo "ESMF_ARCH: " $(ESMF_ARCH) - @echo "FC: " $(FC) - @echo "INC_NETCDF: " $(INC_NETCDF) - @echo "LIB_MPI: " $(LIB_MPI) -test_shr_sys: $(OBJS) - $(LD) -o test_shr_sys $(OBJS) $(LDFLAGS) -test_shr_file: $(OBJS_FILE) - $(LD) -o test_shr_file $(OBJS_FILE) $(LDFLAGS) -test_shr_orb: $(OBJS_ORB) - $(LD) -o test_shr_orb $(OBJS_ORB) $(LDFLAGS) -test_shr_streams: $(OBJS_STRMS) - $(LD) -o test_shr_streams $(OBJS_STRMS) $(LDFLAGS) -test_shr_tInterp: $(OBJS_STIN) - $(LD) -o test_shr_tInterp $(OBJS_STIN) $(LDFLAGS) -test_shr_mpi: $(OBJS_MPI) - $(LD) -o test_shr_mpi $(OBJS_MPI) $(LDFLAGS) -test_shr_scam: $(OBJS_SCAM) - $(LD) -o test_shr_scam $(OBJS_SCAM) $(LDFLAGS) -test_shr_log: $(OBJS_LOG) - $(LD) -o test_shr_log $(OBJS_LOG) $(LDFLAGS) - -clean: - $(RM) -f *.mod *.o *.f *.f90 F mpif.h test_shr_sys test_shr_orb \ - test_shr_file tests_shr_streams tests_shr_tInterp \ - test_shr_mpi libesmf.a test_shr_scam test_shr_log Depends Srcfiles Filepath - -# -# Dependencies -# -Depends: Srcfiles Filepath - ./Mkdepends Filepath Srcfiles > $@ - -paths := $(subst $(space),"\n",$(cpp_dirs)) - -Srcfiles: Filepath - ./Mksrcfiles > $@ - -Filepath: - @echo -e $(paths) > $@ - --include Depends - -# ESMF code... -ifeq ($(ESMF_BLD),$(null)) - -AR := ar -CPP := cpp - -libesmf.a : $(WRFESMF_OBJS) - $(RM) -f libesmf.a - $(AR) $(ARFLAGS) libesmf.a $(WRFESMF_OBJS) - $(RANLIB) libesmf.a - -endif diff --git a/test/old_unit_testers/Mkdepends b/test/old_unit_testers/Mkdepends deleted file mode 100755 index 3852ebc..0000000 --- a/test/old_unit_testers/Mkdepends +++ /dev/null @@ -1,327 +0,0 @@ -#!/usr/bin/env perl - -# Generate dependencies in a form suitable for inclusion into a Makefile. -# The source filenames are provided in a file, one per line. Directories -# to be searched for the source files and for their dependencies are provided -# in another file, one per line. Output is written to STDOUT. -# -# For CPP type dependencies (lines beginning with #include) the dependency -# search is recursive. Only dependencies that are found in the specified -# directories are included. So, for example, the standard include file -# stdio.h would not be included as a dependency unless /usr/include were -# one of the specified directories to be searched. -# -# For Fortran module USE dependencies (lines beginning with a case -# insensitive "USE", possibly preceded by whitespace) the Fortran compiler -# must be able to access the .mod file associated with the .o file that -# contains the module. In order to correctly generate these dependencies -# two restrictions must be observed. -# 1) All modules must be contained in files that have the same base name as -# the module, in a case insensitive sense. This restriction implies that -# there can only be one module per file. -# 2) All modules that are to be contained in the dependency list must be -# contained in one of the source files in the list provided on the command -# line. -# The reason for the second restriction is that since the makefile doesn't -# contain rules to build .mod files the dependency takes the form of the .o -# file that contains the module. If a module is being used for which the -# source code is not available (e.g., a module from a library), then adding -# a .o dependency for that module is a mistake because make will attempt to -# build that .o file, and will fail if the source code is not available. -# -# Author: B. Eaton -# Climate Modelling Section, NCAR -# Feb 2001 - -use Getopt::Std; -use File::Basename; - -# Check for usage request. -@ARGV >= 2 or usage(); - -# Process command line. -my %opt = (); -getopts( "t:w", \%opt ) or usage(); -my $filepath_arg = shift() or usage(); -my $srcfile_arg = shift() or usage(); -@ARGV == 0 or usage(); # Check that all args were processed. - -my $obj_dir; -if ( defined $opt{'t'} ) { $obj_dir = $opt{'t'}; } - -open(FILEPATH, $filepath_arg) or die "Can't open $filepath_arg: $!\n"; -open(SRCFILES, $srcfile_arg) or die "Can't open $srcfile_arg: $!\n"; - -# Make list of paths to use when looking for files. -# Prepend "." so search starts in current directory. This default is for -# consistency with the way GNU Make searches for dependencies. -my @file_paths = ; -close(FILEPATH); -chomp @file_paths; -unshift(@file_paths,'.'); -foreach $dir (@file_paths) { # (could check that directories exist here) - $dir =~ s!/?\s*$!!; # remove / and any whitespace at end of directory name - ($dir) = glob $dir; # Expand tildes in path names. -} - -# Make list of files containing source code. -my @src = ; -close(SRCFILES); -chomp @src; - -# For each file that may contain a Fortran module (*.[fF]90 *.[fF]) convert the -# file's basename to uppercase and use it as a hash key whose value is the file's -# basename. This allows fast identification of the files that contain modules. -# The only restriction is that the file's basename and the module name must match -# in a case insensitive way. -my %module_files = (); -my ($f, $name, $path, $suffix, $mod); -my @suffixes = ('\.[fF]90', '\.[fF]' ); -foreach $f (@src) { - ($name, $path, $suffix) = fileparse($f, @suffixes); - ($mod = $name) =~ tr/a-z/A-Z/; - $module_files{$mod} = $name; -} - -# Now make a list of .mod files in the file_paths. If a .o source dependency -# can't be found based on the module_files list above, then maybe a .mod -# module dependency can if the mod file is visible. -my %trumod_files = (); -my ($dir); -my ($f, $name, $path, $suffix, $mod); -my @suffixes = ('\.mod' ); -foreach $dir (@file_paths) { - @filenames = (glob("$dir/*.mod")); - foreach $f (@filenames) { - ($name, $path, $suffix) = fileparse($f, @suffixes); - ($mod = $name) =~ tr/a-z/A-Z/; - $trumod_files{$mod} = $name; - } -} - -#print STDERR "\%module_files\n"; -#while ( ($k,$v) = each %module_files ) { -# print STDERR "$k => $v\n"; -#} - -# Find module and include dependencies of the source files. -my ($file_path, $rmods, $rincs); -my %file_modules = (); -my %file_includes = (); -my @check_includes = (); -foreach $f ( @src ) { - - # Find the file in the seach path (@file_paths). - unless ($file_path = find_file($f)) { - if (defined $opt{'w'}) {print STDERR "$f not found\n";} - next; - } - - # Find the module and include dependencies. - ($rmods, $rincs) = find_dependencies( $file_path ); - - # Remove redundancies (a file can contain multiple procedures that have - # the same dependencies). - $file_modules{$f} = rm_duplicates($rmods); - $file_includes{$f} = rm_duplicates($rincs); - - # Make a list of all include files. - push @check_includes, @{$file_includes{$f}}; -} - -#print STDERR "\%file_modules\n"; -#while ( ($k,$v) = each %file_modules ) { -# print STDERR "$k => @$v\n"; -#} -#print STDERR "\%file_includes\n"; -#while ( ($k,$v) = each %file_includes ) { -# print STDERR "$k => @$v\n"; -#} -#print STDERR "\@check_includes\n"; -#print STDERR "@check_includes\n"; - -# Find include file dependencies. -my %include_depends = (); -while (@check_includes) { - $f = shift @check_includes; - if (defined($include_depends{$f})) { next; } - - # Mark files not in path so they can be removed from the dependency list. - unless ($file_path = find_file($f)) { - $include_depends{$f} = -1; - next; - } - - # Find include file dependencies. - ($rmods, $include_depends{$f}) = find_dependencies($file_path); - - # Add included include files to the back of the check_includes list so - # that their dependencies can be found. - push @check_includes, @{$include_depends{$f}}; - - # Add included modules to the include_depends list. - if ( @$rmods ) { push @{$include_depends{$f}}, @$rmods; } -} - -#print STDERR "\%include_depends\n"; -#while ( ($k,$v) = each %include_depends ) { -# print STDERR (ref $v ? "$k => @$v\n" : "$k => $v\n"); -#} - -# Remove include file dependencies that are not in the Filepath. -my $i, $ii; -foreach $f (keys %include_depends) { - - unless (ref $include_depends{$f}) { next; } - $rincs = $include_depends{$f}; - unless (@$rincs) { next; } - $ii = 0; - $num_incs = @$rincs; - for ($i = 0; $i < $num_incs; ++$i) { - if ($include_depends{$$rincs[$ii]} == -1) { - splice @$rincs, $ii, 1; - next; - } - ++$ii; - } -} - -# Substitute the include file dependencies into the %file_includes lists. -foreach $f (keys %file_includes) { - my @expand_incs = (); - - # Initialize the expanded %file_includes list. - my $i; - unless (@{$file_includes{$f}}) { next; } - foreach $i (@{$file_includes{$f}}) { - push @expand_incs, $i unless ($include_depends{$i} == -1); - } - unless (@expand_incs) { - $file_includes{$f} = []; - next; - } - - # Expand - for ($i = 0; $i <= $#expand_incs; ++$i) { - push @expand_incs, @{ $include_depends{$expand_incs[$i]} }; - } - - $file_includes{$f} = rm_duplicates(\@expand_incs); -} - -#print STDERR "expanded \%file_includes\n"; -#while ( ($k,$v) = each %file_includes ) { -# print STDERR "$k => @$v\n"; -#} - -# Print dependencies to STDOUT. -foreach $f (sort keys %file_modules) { - $f =~ /(.+)\./; - $target = "$1.o"; - if ( defined $opt{'t'} ) { $target = "$opt{'t'}/$1.o"; } - print "$target : $f @{$file_modules{$f}} @{$file_includes{$f}}\n"; -} - -#-------------------------------------------------------------------------------------- - -sub find_dependencies { - - # Find dependencies of input file. - # Use'd Fortran 90 modules are returned in \@mods. - # Files that are "#include"d by the cpp preprocessor are returned in \@incs. - - my( $file ) = @_; - my( @mods, @incs ); - - open(FH, $file) or die "Can't open $file: $!\n"; - - while ( ) { - # Search for "#include" and strip filename when found. - if ( /^#include\s+[<"](.*)[>"]/ ) { - push @incs, $1; - } - # Search for Fortran include dependencies. - elsif ( /^\s*include\s+['"](.*)['"]/ ) { #" for emacs fontlock - push @incs, $1; - } - # Search for module dependencies. - elsif ( /^\s*USE\s+(\w+)/i ) { - ($module = $1) =~ tr/a-z/A-Z/; - # Return dependency in the form of a .o version of the file that contains - # the module. this is from the source list. - if ( defined $module_files{$module} ) { - if ( defined $obj_dir ) { - push @mods, "$obj_dir/$module_files{$module}.o"; - } else { - push @mods, "$module_files{$module}.o"; - } - } - # Return dependency in the form of a .mod version of the file that contains - # the module. this is from the .mod list. only if .o version not found - elsif ( defined $trumod_files{$module} ) { - if ( defined $obj_dir ) { - push @mods, "$obj_dir/$trumod_files{$module}.mod"; - } else { - push @mods, "$trumod_files{$module}.mod"; - } - } - } - } - close( FH ); - return (\@mods, \@incs); -} - -#-------------------------------------------------------------------------------------- - -sub find_file { - -# Search for the specified file in the list of directories in the global -# array @file_paths. Return the first occurance found, or the null string if -# the file is not found. - - my($file) = @_; - my($dir, $fname); - - foreach $dir (@file_paths) { - $fname = "$dir/$file"; - if ( -f $fname ) { return $fname; } - } - return ''; # file not found -} - -#-------------------------------------------------------------------------------------- - -sub rm_duplicates { - -# Return a list with duplicates removed. - - my ($in) = @_; # input arrary reference - my @out = (); - my $i; - my %h = (); - foreach $i (@$in) { - $h{$i} = ''; - } - @out = keys %h; - return \@out; -} - -#-------------------------------------------------------------------------------------- - -sub usage { - ($ProgName = $0) =~ s!.*/!!; # name of program - die < Srcfiles") or die "Can't open Srcfiles\n"; - -if ( open(FILEPATH,"< Filepath") ) { - @paths = ; - close( FILEPATH ); -} else { - @paths = (); -} -chomp @paths; -unshift(@paths, '.'); -foreach $dir (@paths) { # (could check that directories exist here) - $dir =~ s!/?\s*$!!; # remove / and any whitespace at end of directory name - ($dir) = glob $dir; # Expand tildes in path names. -} - -# Loop through the directories and add each filename as a hash key. This -# automatically eliminates redunancies. -%src = (); -foreach $dir (@paths) { - @filenames = (glob("$dir/*.[Fc]"), glob("$dir/*.[Ff]90")); - foreach $filename (@filenames) { - $filename =~ s!.*/!!; # remove part before last slash - $src{$filename} = ""; - } -} - -foreach $file ( sort keys %src ) { - print SRC "$file\n"; -} -close( SRC ); - -#-------------------------------------------------------------------------------------- - -sub usage { - ($ProgName = $0) =~ s!.*/!!; # name of program - die < 0.0_r8 )then - diff = abs(data(i,j,f) - exp_data(i,j,f)) - ndata = ndata + 1 - meansq = meansq + diff**2 - if ( trim(lcrittype) == "rel_diff" .and. diff > 0.0_r8 ) diff = diff / max( abs(data(i,j,f)), abs(exp_data(i,j,f)) ) - if ( diff > max_diff ) max_diff = diff - if ( diff > eps .and. .not. trim(lcrittype) == "rms_diff" )then - bundle_closeto_expected = .false. - end if - end if - end do - end do - end do outloop - deallocate( mask ) - rms_diff = sqrt(meansq/ndata) - if ( rms_diff > eps .and. trim(lcrittype) == "rms_diff" ) bundle_closeto_expected = .false. - write(*,*) "bundle_closeto_expected: max_diff = ", max_diff, " RMS diff = ", rms_diff - end if - -end function bundle_closeto_expected - -logical function bundle_metadata_is_expected( bun, expected_bun ) - use dshr_bundle, only : dshr_bundle_domainPtr, dshr_bundle_getDims, dshr_bundle_getFieldList, & - dshr_bundle_getDate - use dshr_domain, only : dshr_domain_compare - implicit none - - type(dshr_bundle_bundleType), intent(IN) :: bun ! bundle to test - type(dshr_bundle_bundleType), intent(IN) :: expected_bun ! expected bundle - - type(dshr_domain_domainType),pointer :: domain - type(dshr_domain_domainType),pointer :: exp_domain - logical :: status - integer :: ni, nj, nf, exp_ni, exp_nj, exp_nf - integer :: date, sec, exp_date, exp_sec - character(SHR_KIND_CX) :: fldlist, exp_fldlist - - - call dshr_bundle_domainPtr( bun, domain ) - call dshr_bundle_domainPtr( expected_bun, exp_domain ) - - status = dshr_domain_compare( domain, exp_domain, method=dshr_domain_compareMaskIdent, eps=0.0_r8 ) - if ( status )then - status = dshr_domain_compare( domain, exp_domain, method=dshr_domain_compareXYabs, eps=0.0_r8 ) - end if - if ( status )then - call dshr_bundle_getDims( bun, ni, nj, nf ) - call dshr_bundle_getDims( bun, exp_ni, exp_nj, exp_nf ) - if ( ni /= exp_ni .or. nj /= exp_nj .or. nf /= exp_nf ) status = .false. - end if - if ( status )then - call dshr_bundle_getFieldList( bun, fldlist ) - call dshr_bundle_getFieldList( expected_bun, exp_fldlist ) - if ( trim(fldlist) /= trim(exp_fldlist) ) status = .false. - end if - if ( status )then - call dshr_bundle_getDate (bun,date,sec) - call dshr_bundle_getDate (expected_bun,exp_date,exp_sec) - if ( date /= exp_date .or. sec /= exp_sec ) status = .false. - end if - - bundle_metadata_is_expected = status - -end function bundle_metadata_is_expected - -subroutine bundle_fill_cosz( scale, orb_eccen, orb_mvelpp, orb_lambm0, orb_obliqr, sdate_ub, domain, bun, kfld ) -! Fill a bundle with data scaled by the average cosine of the solar zenith angle - use shr_string_mod - use shr_const_mod - use shr_orb_mod - use dshr_domain - use shr_sys_mod - implicit none - real(r8), intent(IN) :: scale - real(r8), intent(IN) :: orb_eccen, orb_mvelpp, orb_lambm0, orb_obliqr - type(shr_date), intent(IN) :: sdate_ub ! Upper bound of date for - type(dshr_domain_domainType), pointer :: domain - type(dshr_bundle_bundleType), intent(INOUT) :: bun ! bundle to fill - integer, intent(in) :: kfld ! Which field number to fill - - character(len=*), parameter :: subname = "bundle_fill_cosz" - real(r8), pointer :: data(:,:,:), lat(:,:), lon(:,:), sumcosz(:,:) - real(r8) :: cosz, calday, declin, eccf, calday_end - integer :: i, j, f, ni, nj, nf, rc, t, ntimes, date_lb, sec_lb - integer, parameter :: dtime = 18 - type(shr_date) :: sdate - - call dshr_domain_getDims(domain,ni,nj) - allocate( lat(ni,nj) ) - allocate( lon(ni,nj) ) - allocate( sumcosz(ni,nj) ) - call dshr_domain_getData( domain, lat, "lat" ) - call dshr_domain_getData( domain, lon, "lon" ) - lat = lat * SHR_CONST_PI / 180._r8 - lon = lon * SHR_CONST_PI / 180._r8 - - call dshr_bundle_assignPtr( bun, data ) - call dshr_bundle_getDate( bun, cdate=date_lb, sec=sec_lb ) - sdate = shr_date_initCDate( date_lb, 3600*24/dtime, sec_lb ) - calday_end = shr_date_getJulian( sdate_ub ) - sumcosz(:,:) = 0.0_r8 - calday = 0.0_r8 - ntimes = 0 - calday = shr_date_getJulian( sdate ) - nf = size( data, 3 ) - if ( kfld <= 0 .or. kfld > nf ) call shr_sys_abort( 'input kfld is out of bounds' ) - do while( sdate < sdate_ub .or. sdate == sdate_ub ) - ntimes = ntimes + 1 - call shr_orb_decl(calday ,orb_eccen ,orb_mvelpp ,orb_lambm0 ,orb_obliqr ,declin,eccf) - do j = 1, nj - do i = 1, ni - cosz = shr_orb_cosz(calday,lat(i,j),lon(i,j),declin) - if ( cosz < 0.01_r8 ) cosz = 0.01_r8 - if ( cosz < 0.001_r8 ) cosz = 0.001_r8 - sumcosz(i,j) = cosz + sumcosz(i,j) - end do - end do - call shr_date_adv1step( sdate ) - calday = shr_date_getJulian( sdate ) - end do - data(:,:,kfld) = sumcosz(:,:)*scale/real(ntimes,r8) - - nullify( data ) - nullify( domain ) - deallocate( lat ) - deallocate( lon ) - deallocate( sumcosz ) - -end subroutine bundle_fill_cosz - -end module bundle_expected diff --git a/test/old_unit_testers/config.h b/test/old_unit_testers/config.h deleted file mode 100644 index 03f5a6a..0000000 --- a/test/old_unit_testers/config.h +++ /dev/null @@ -1,7 +0,0 @@ -#ifdef FORTRAN_SAME -#define FC_FUNC(name,NAME) name -#elif FORTRAN_UNDERSCORE_ -#define FC_FUNC(name,NAME) name ##_ -#elif FORTRAN_DOUBLE_UNDERSCORE_ -#define FC_FUNC(name,NAME) name ##__ -#endif diff --git a/test/old_unit_testers/make.Macros b/test/old_unit_testers/make.Macros deleted file mode 100644 index 567cac8..0000000 --- a/test/old_unit_testers/make.Macros +++ /dev/null @@ -1,369 +0,0 @@ -#--------------------------------------------------------------------- -# Platform specific macros for csm_share unit tests -#------------------------------------------------------------------------ -# Set up special characters -null := - -.SUFFIXES: .F90 .c .o - -# Cancel rule to make *.o from *.mod -%.o : %.mod - -# Defines to use everywhere - -cpre = $(null)-WF,-D$(null) -CPPDEF := -DESMF_3 -D_NETCDF - -ifeq ($(ESMF_3),TRUE) - CPPDEF += -DESMF_3 -endif - -ifneq ($(SPMD),TRUE) - CPPDEF += -D_MPISERIAL -endif - -LD := $(FC) - - -CPPDEF += -DSEQ_ESMF -DNOPERF -# For linking with external ESMF -# If ESMF_BLD is defined then set ESMF_MOD and ESMF_LIB based on it -ifneq ($(ESMF_BLD),$(null)) - ESMF_BOPT := g - ESMF_MOD = $(ESMF_BLD)/mod/mod$(ESMF_BOPT)/$(ESMF_ARCH) - ESMF_LIB = $(ESMF_BLD)/lib/lib$(ESMF_BOPT)/$(ESMF_ARCH) -else - ESMF_MOD := . - ESMF_LIB := . -endif - -# Determine platform -UNAMES := $(shell uname -s) - -.F90.o: - $(FC) -c $(FFLAGS) $< -.c.o: - $(CC) -c $(CFLAGS) $< - -#------------------------------------------------------------------------ -# Linux -#------------------------------------------------------------------------ - -ifeq ($(UNAMES),Linux) - -ifeq ($(FC),f77) - FC := pgfortran -endif - -CFLAGS := -LDFLAGS := -ifeq ($(FC),pgfortran) - CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ -DCPRPGI - ifeq ($(INC_MPI),$(null)) - INC_MPI := /usr/local/mpich-1.2.7p1-pgi-pgcc-pghf-6.1-3/include - endif - ifeq ($(LIB_MPI),$(null)) - LIB_MPI := /usr/local/mpich-1.2.7p1-pgi-pgcc-pghf-6.1-3/lib - endif - ifeq ($(INC_NETCDF),$(null)) - INC_NETCDF := /usr/local/netcdf-3.6.1-pgi-hpf-cc-6.1-6/include - endif - ifeq ($(LIB_NETCDF),$(null)) - LIB_NETCDF := /usr/local/netcdf-3.6.1-pgi-hpf-cc-6.1-6/lib - endif - CC := pgcc - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Linux.pgi.32.mpich.default - else - ESMF_ARCH := Linux.pgi.32.mpiuni.default - endif - F90FLAGS := -Mfree - FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) -Mrecursive -Mdalign \ - -Mextend $(cpp_path) -I$(INC_NETCDF) \ - -g -Mbounds -I$(INC_MPI) - ifneq ($(FLTTRAP),FALSE) - FFLAGS += -Ktrap=fp - endif - LDFLAGS += -Bstatic -endif -ifeq ($(FC),nagfor) - CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ -DCPRNAG - ifeq ($(INC_MPI),$(null)) - INC_MPI := /home/santos/mpich-gcc-nag/include - endif - ifeq ($(LIB_MPI),$(null)) - LIB_MPI := /home/santos/mpich-gcc-nag/lib - endif - ifeq ($(INC_NETCDF),$(null)) - INC_NETCDF := /usr/local/netcdf-gcc-nag/include - endif - ifeq ($(LIB_NETCDF),$(null)) - LIB_NETCDF := /usr/local/netcdf-gcc-nag/lib - endif - CC := gcc - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Linux.pgi.32.mpich.default - else - ESMF_ARCH := Linux.pgi.32.mpiuni.default - endif - FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ - $(cpp_path) -I$(INC_NETCDF) \ - -g -I$(INC_MPI) - FFLAGS += -wmismatch=mpi_send,mpi_recv,mpi_bcast,mpi_reduce,mpi_allreduce - ifeq ($(FLTTRAP),FALSE) - FFLAGS += -ieee=full - endif -endif -ifeq ($(FC),pathf90) - CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ - CC := pathcc - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Linux..pathscale.32.mpich.default - else - ESMF_ARCH := Linux.pathscale.32.mpiuni.default - endif - FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ - $(cpp_path) -I$(INC_NETCDF) \ - -g -extend_source -ftpp -fno-second-underscore -endif -ifeq ($(FC),ftn) - CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ - CC := pathcc - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Linux..pathscale.32.mpich.default - else - ESMF_ARCH := Linux.pathscale.32.mpiuni.default - endif - FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ - $(cpp_path) -I$(INC_NETCDF) \ - -g -extend_source -ftpp -fno-second-underscore -endif -ifeq ($(FC),ifort) - CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ -DCPRINTEL - CC := icc - ifeq ($(INC_MPI),$(null)) - INC_MPI := /usr/local/mpich-intel/include - endif - ifeq ($(LIB_MPI),$(null)) - LIB_MPI := /usr/local/mpich-intel/lib - endif - ifeq ($(INC_NETCDF),$(null)) - INC_NETCDF := /usr/local/netcdf-intel/include - endif - ifeq ($(LIB_NETCDF),$(null)) - LIB_NETCDF := /usr/local/netcdf-intel/lib - endif - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Linux.ifort.32.mpich.default - else - ESMF_ARCH := Linux.ifort.32.mpiuni.default - endif - FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ - $(cpp_path) -I$(INC_NETCDF) \ - -m64 -ftz -g -fp-model precise -convert big_endian -assume byterecl -traceback -CB - CFLAGS += -m64 -ftz -v - LDFLAGS += -m64 -endif -ifeq ($(FC),gfortran) - CPPDEF += -DLINUX -DFORTRAN_SAME -DCPRGNU - CC := cc - FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ - $(FPPFLAGS) -g -fbounds-check -fno-range-check -m64 - CFLAGS += -m64 - LDFLAGS += -static -m64 -ffpe-trap=invalid,zero,overflow -fno-range-check - ifneq ($(FLTTRAP),FALSE) - LDFLAGS += -ffpe-trap=invalid,zero,overflow - FFLAGS += -ffpe-trap=invalid,zero,overflow - endif -endif -ifeq ($(FC),g95) - CPPDEF += -DFORTRAN_SAME - CC := gcc - FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ - $(FPPFLAGS) -g -fbounds-check -m64 -ffree-line-length-huge - CFLAGS += -m64 - LDFLAGS += -fstatic -m64 - ifneq ($(FLTTRAP),FALSE) - LDFLAGS += -ffpe-trap=invalid,zero,overflow - FFLAGS += -ffpe-trap=invalid,zero,overflow - endif -endif -ifeq ($(FC),xlf2003_r) - CPPDEF += -DLINUX -DFORTRAN_SAME -DCPRIBM - AIX_CPPDEF := $(patsubst -D%,$(cpre)%,$(CPPDEF)) - FPPFLAGS := -WF,-P,$(AIX_CPPDEF) - ESMF_ARCH := AIX.default.64.mpiuni.default - ifeq ($(INC_NETCDF),$(null)) - INC_NETCDF := /soft/libraries/netcdf/4.2.1.1/cnk-xl/V1R2M0-20130417/include - endif - ifeq ($(LIB_NETCDF),$(null)) - LIB_NETCDF := /soft/libraries/netcdf/4.2.1.1/cnk-xl/V1R2M0-20130417/lib - endif - FREEFLAGS := -qsuffix=f=f90:cpp=F90 - FFLAGS := $(FREEFLAGS) $(cpp_path) -I$(INC_NETCDF) -I$(LIB_NETCDF) $(FPPFLAGS) \ - -qarch=auto -qspillsize=2500 \ - -g -qfullpath -q64 -C -d - CC := cc_r - CFLAGS += -O2 -q64 - LDFLAGS += -q64 -L/bgsys/drivers/ppcfloor/comm/lib -Wl,--relax -Wl,--allow-multiple-definition -qfullpath - ifneq ($(FLTTRAP),FALSE) - FFLAGS += -qinitauto=FF911299 -qflttrap=ov:zero:inv:en -qhalt=w - endif - ifeq ($(SPMD),TRUE) - LDFLAGS += -lmpi_r - endif - ifeq ($(SMP),TRUE) - FFLAGS += -qsmp=omp:noopt - LDFLAGS += -qsmp=omp:noopt - endif - -endif -LDFLAGS += -L$(LIB_NETCDF) -lnetcdf -ifeq ($(SPMD),TRUE) - LDFLAGS += -L$(LIB_MPI) -lmpich -endif -CFLAGS += $(cpp_path) $(CPPDEF) -LD := $(FC) -ARFLAGS := ru -RANLIB := echo - -# For linking with external ESMF -ifneq ($(ESMF_BLD),$(null)) - FFLAGS += -M$(ESMF_BLD)/mod/mod$(ESMF_BOPT)/$(ESMF_ARCH) -M. -endif - -#.F90.o: -# $(FC) $(CPPFLAGS) $< -# $(FC) $(F90FLAGS) $*.f - -endif -#------------------------------------------------------------------------ -# AIX -#------------------------------------------------------------------------ -ifeq ($(UNAMES),AIX) - -ifeq ($(SPMD),TRUE) - FC := mpxlf90_r - ESMF_ARCH := AIX.default.64.mpi.default -else - FC := xlf90_r - ESMF_ARCH := AIX.default.64.mpiuni.default -endif -CPPDEF += -DFORTRAN_SAME -DCPRIBM -AIX_CPPDEF := $(patsubst -D%,$(cpre)%,$(CPPDEF)) -FPPFLAGS := -WF,-P,-DAIX $(AIX_CPPDEF) -FREEFLAGS := -qsuffix=f=f90:cpp=F90 -FFLAGS := $(FREEFLAGS) $(cpp_path) -I$(INC_NETCDF) -I$(LIB_NETCDF) $(FPPFLAGS) \ - -qarch=auto -qspillsize=2500 \ - -g -qfullpath -q64 -C -d -CC := mpcc_r -CFLAGS := $(cpp_path) -O2 $(CPPDEF) -q64 -LDFLAGS := -L$(LIB_NETCDF) -lnetcdf -q64 -lmassv -LD := $(FC) -ifneq ($(FLTTRAP),FALSE) - FFLAGS += -qinitauto=FF911299 -qflttrap=ov:zero:inv:en -qhalt=w -endif -ifeq ($(FC),mpxlf90_r) - LDFLAGS += -lmpi_r -endif -ifeq ($(SMP),TRUE) - FFLAGS += -qsmp=omp:noopt - LDFLAGS += -qsmp=omp:noopt -endif -ARFLAGS := -X 64 ru -RANLIB := ranlib - -endif - -#------------------------------------------------------------------------ -# Darwin -#------------------------------------------------------------------------ -ifeq ($(UNAMES),Darwin) - -CC := gcc -LDFLAGS := -g -L$(LIB_NETCDF) -lnetcdf -lSystemStubs - -ifeq ($(FC),ifort) - CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ - CC := icc - ifeq ($(INC_MPI),$(null)) - INC_MPI := /usr/local/mpich-intel/include - endif - ifeq ($(LIB_MPI),$(null)) - LIB_MPI := /usr/local/mpich-intel/lib - endif - ifeq ($(INC_NETCDF),$(null)) - INC_NETCDF := /usr/local/netcdf-intel/include - endif - ifeq ($(LIB_NETCDF),$(null)) - LIB_NETCDF := /usr/local/netcdf-intel/lib - endif - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Linux.ifort.32.mpich.default - else - ESMF_ARCH := Linux.ifort.32.mpiuni.default - endif - FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ - $(cpp_path) -I$(INC_NETCDF) \ - -m64 -ftz -g -fp-model precise -convert big_endian -assume byterecl -traceback -CB - CFLAGS += -m64 -ftz -v - LDFLAGS += -m64 - gptl.o: gptl.c - $(CC) -c -I/usr/include/machine $(CFLAGS) $< -endif -ifeq ($(FC),g95) - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Darwin.g95.32.mpich.default - else - ESMF_ARCH := Darwin.g95.32.mpiuni.default - endif - FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ - $(FPPFLAGS) -g -fbounds-check -fstatic -ffree-line-length-huge -ffree-form \ - -ftrace=full -endif -ifeq ($(FC),gfortran) - ifeq ($(SPMD),TRUE) - ESMF_ARCH := Darwin.gfortran.32.mpich.default - else - ESMF_ARCH := Darwin.gfortran.32.mpiuni.default - endif - FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ - $(FPPFLAGS) -g -fbounds-check -fno-range-check - ifneq ($(FLTTRAP),FALSE) - LDFLAGS += -ffpe-trap=invalid,zero,overflow - FFLAGS += -ffpe-trap=invalid,zero,overflow - endif - LDFLAGS += -static -endif -CFLAGS := $(cpp_path) -O2 $(CPPDEF) \ - -I/Developer/SDKs/MacOSX10.4.0.sdk/usr/include/malloc -I/usr/include -I/usr/include/malloc -ARFLAGS := ru -RANLIB := ranlib -LD := $(FC) - -# For linking with MPICH -ifeq ($(SPMD),TRUE) - LDFLAGS += -lmpich - LD := mpif90 -endif -LDFLAGS += -lSystemStubs_profile - -# For linking with external ESMF -ifneq ($(ESMF_BLD),$(null)) - LDFLAGS += -lgcc_s.1.0 -lSystemStubs_debug -endif - -endif - -#------------------------------------------------------------------------ -# End of platform specific -#------------------------------------------------------------------------ -# For linking with external ESMF -ifneq ($(ESMF_BLD),$(null)) - include $(ESMF_BLD)/lib/esmf.mk - LDFLAGS += $(ESMF_F90LINKRPATHS) $(ESMF_F90LINKPATHS) $(ESMF_F90ESMFLINKLIBS) $(ESMF_CXXLINKLIBS) - FFLAGS += $(ESMF_F90COMPILEPATHS) - LD := $(ESMF_F90LINKER) -endif - -RM := rm diff --git a/test/old_unit_testers/namelist b/test/old_unit_testers/namelist deleted file mode 100644 index a099650..0000000 --- a/test/old_unit_testers/namelist +++ /dev/null @@ -1,10 +0,0 @@ -# No stop date -&ccsm_inparm - case_desc = 'Erik' -/ -&timemgr_inparm - restart_monthly = .true. - atm_cpl_dt = 1200 - orb_iyear_AD = 1950 - start_ymd = 1231 -/ diff --git a/test/old_unit_testers/nl/atm.stdin b/test/old_unit_testers/nl/atm.stdin deleted file mode 100644 index 1538fd0..0000000 --- a/test/old_unit_testers/nl/atm.stdin +++ /dev/null @@ -1,2 +0,0 @@ -&atm_inparm -/ diff --git a/test/old_unit_testers/nl/cpl.stdin b/test/old_unit_testers/nl/cpl.stdin deleted file mode 100644 index a60131f..0000000 --- a/test/old_unit_testers/nl/cpl.stdin +++ /dev/null @@ -1,2 +0,0 @@ -&cpl_inparm -/ diff --git a/test/old_unit_testers/nl/ice.stdin b/test/old_unit_testers/nl/ice.stdin deleted file mode 100644 index 0b67c00..0000000 --- a/test/old_unit_testers/nl/ice.stdin +++ /dev/null @@ -1,2 +0,0 @@ -&ice_inparm -/ diff --git a/test/old_unit_testers/nl/lnd.stdin b/test/old_unit_testers/nl/lnd.stdin deleted file mode 100644 index b10ac41..0000000 --- a/test/old_unit_testers/nl/lnd.stdin +++ /dev/null @@ -1,2 +0,0 @@ -&lnd_inparm -/ diff --git a/test/old_unit_testers/nl/ocn.stdin b/test/old_unit_testers/nl/ocn.stdin deleted file mode 100644 index 70ab49f..0000000 --- a/test/old_unit_testers/nl/ocn.stdin +++ /dev/null @@ -1,2 +0,0 @@ -&ocn_inparm -/ diff --git a/test/old_unit_testers/run_dshr_bundle_test b/test/old_unit_testers/run_dshr_bundle_test deleted file mode 100755 index 7ac6300..0000000 --- a/test/old_unit_testers/run_dshr_bundle_test +++ /dev/null @@ -1,96 +0,0 @@ -#!/bin/csh -# -# Script to run the dshr_bundle unit test. -# -#----------------------------------------------------------------------- -# NCAR IBM SP: bluevista -# Usage: env CSMBL_ROOT= bsub < run_dshr_bundle -#----------------------------------------------------------------------- -## Setting LSF options for batch queue submission. -#BSUB -a poe # use poe for multiprocessing -## Number of tasks and tasks per node (CHANGE THIS IF YOU TURN smp on) -#BSUB -n 1 # total number of MPI-tasks (processors) needed -#BSUB -R "span[ptile=2]" # max number of tasks (MPI) per node -#BSUB -o out.%J # output filename -#BSUB -e out.%J # error filename -#BSUB -q share # queue -#BSUB -W 1:10 # wall clock limit -#BSUB -P 93300006 # Project number to charge to (MAKE SURE YOU CHANGE THIS!!!) - -# -#----------------------------------------------------------------------- -# CGD Linux cluster : bangkok -# Usage: env CSMBL_ROOT= qsub run_dshr_bundle -#----------------------------------------------------------------------- -# Name of the queue (CHANGE THIS if needed) -#PBS -q long -# Number of nodes (CHANGE THIS if needed) -#PBS -l nodes=2:ppn=2:ecc -# output file base name -#PBS -N bundle.linux.log -# Put standard error and standard out in same file -#PBS -j oe -# Export all Environment variables -#PBS -V -# End of options -# - -# If batch go to work directory -if ( $?PBS_JOBID )then - cd ${PBS_O_WORKDIR} -endif - -if ( $?QSUB_REQID )then - cd ${QSUB_WORKDIR} -endif - -set uname = `uname -s` - -# -# Set make command to use -# -setenv GMAKE gmake -if ( $uname == "Darwin" ) setenv GMAKE "make FC=g95" - -# -# Set mpirun to use -# -if ( $uname == "Darwin" )then - set mpi = "mpirun -np 2" -else if ( $uname == "AIX" )then - set mpi = "mpirun.lsf" -else if ( $uname == "Linux" )then - set mpi = "/usr/local/mpich-1.2.7p1-pgi-pgcc-pghf-6.1-3/bin/mpirun -np 2" -endif - -# -# Standard tests -# -foreach opt ( "" "SPMD") - # Build - $GMAKE clean - set SPMD = "FALSE" - set optbld = "" - if ( $opt == "SPMD" ) set SPMD = "TRUE" - set optbld="SPMD=$SPMD" - # Run save output to log file - echo "Build with options: $optbld" - $GMAKE $optbld test_dshr_bundle >&! compile.log || exit 1 - echo "Run with options: $optbld" - if ( $SPMD == "TRUE" )then - $mpi test_dshr_bundle >! bundle.log - set retstatus=$status - else - test_dshr_bundle >! bundle.log - set retstatus=$status - endif - if ( $retstatus != 0 ) then - echo "Error -- run status returns error: $retstatus" - grep "All expected tests ran successfully" bundle.log - if ( $status != 0 ) exit 2 - endif -end - -$GMAKE clean -\rm *.nc bundle.log* compile.log -echo "Testing successful\! PASS\!" diff --git a/test/old_unit_testers/run_file_test b/test/old_unit_testers/run_file_test deleted file mode 100755 index 09975fc..0000000 --- a/test/old_unit_testers/run_file_test +++ /dev/null @@ -1,68 +0,0 @@ -#!/bin/csh -# -# Run test for shr_file_mod module. -# -#set echo -set cwd = `pwd` -echo "Make test" -setenv GMAKE gmake -if ( `uname -s` == "Darwin" ) setenv GMAKE "make FC=g95" -$GMAKE test_shr_file -if ( $status != 0 )then - echo "Test failed" - exit 999 -endif -echo "make stdio namelists" -foreach i ( "cpl" "ice" "ocn" ) - cat << EOF > ${i}_stdio.nml -&stdio - dir = "$cwd/nl" - stdout = "${i}.log" - stdin = "${i}.stdin" -/ -EOF -end -foreach i ( "atm" "lnd" ) - cat << EOF > ${i}_stdio.nml -&stdio - dir = "$cwd/nl" - stdout = "${i}.log" - nlfile = "${i}.stdin" -/ -EOF -end -echo "Softlink namelist files appropriately" -foreach i ( "atm" "lnd" "cpl" "ice" "ocn" ) - \ln -f -s $cwd/{$i}_stdio.nml $cwd/nl/. -end -echo "run test" -test_shr_file -cat test_shr_file.log -if ( $status != 0 )then - echo "Test failed" - exit 999 -endif -echo "Check test output.." -egrep "<<<<<<<>>>>>>>>>" test_shr_file.log -if ( $status == 0 )then - echo "Test failed test_shr_file.log has string expected for model log files"" - exit 999 -endif -foreach i ( "atm" "lnd" "cpl" "ice" "ocn" ) - grep "<<<<<<<>>>>>>>>>" nl/${i}.log - if ( $status != 0 )then - echo "Test failed $i log does not have expected string" - exit 999 - endif -end -echo "Test passed" -echo "clean up..." -$GMAKE clean -foreach i ( "atm" "lnd" "cpl" "ice" "ocn" ) - \rm ${i}_stdio.nml nl/${i}.log -end -echo -echo -echo - -echo "PASS" diff --git a/test/old_unit_testers/test_mod.F90 b/test/old_unit_testers/test_mod.F90 deleted file mode 100644 index a2b0eef..0000000 --- a/test/old_unit_testers/test_mod.F90 +++ /dev/null @@ -1,339 +0,0 @@ -module test_mod - -use shr_kind_mod, only : SHR_KIND_R8 -use shr_sys_mod, only : shr_sys_abort - -implicit none - -public test_init -public test_is -public test_close -public test_final - -integer, save :: ntests = 0 -integer, save :: npass = 0 -integer, save :: num_expected = 0 -logical, save :: num_expected_given = .false. -character(*), parameter :: formatTest = '(A4, " ", i5.5, " - ", A)' -character(*), parameter :: formatArrayMatch = & - '(" (all ", i5, " values match)")' -character(*), parameter :: formatArray2DMatch = & - '(" (all ", i5, "x", i5, " values match)")' -character(*), parameter :: formatArrayMisMatch = & - '(" (only ", i5, " values of ", i5, " values match)")' -character(*), parameter :: formatArray2DMisMatch = & - '(" (only ", i5, " values of ", i5, "x", i5, " values match)")' -character(*), parameter :: formatRArrayClose = & - '(" (all ", i5, " values are within", 1pe9.1e2, " )")' -character(*), parameter :: formatRArrayNotClose = & - '(" (only ", i5, " values of ", i5, " values are within", 1pe9.1e2, " max diff= ", 1pe9.1e2, ")")' -character(*), parameter :: formatRClose = & - '(" ( value within", 1pe9.1e2, " )")' -character(*), parameter :: formatRNotClose = & - '(" ( value within", 1pe9.1e2, " diff= ", 1pe9.1e2, ")")' - -interface test_is - module procedure test_is_logical - module procedure test_is_logical1D - module procedure test_is_string - module procedure test_is_integer - module procedure test_is_integer1D - module procedure test_is_real1D - module procedure test_is_real2D - module procedure test_is_realScalar -end interface test_is - -interface test_close - module procedure test_close_real1D - module procedure test_close_realScalar -end interface test_close - -private test_is_logical -private test_is_string -private test_is_integer -private test_is_integer1D -private test_is_real1D -private test_is_realScalar -private test_close_real1D - -contains - - -subroutine test_init( num_expected_tests ) - integer, intent(IN), optional :: num_expected_tests - - if ( present(num_expected_tests) ) then - num_expected = num_expected_tests - num_expected_given = .true. - write(*,formatTest) "1...", num_expected, "expected tests" - write(*,*) - end if - -end subroutine test_init - -subroutine test_is_logical( pass, description ) - - implicit none - - logical, intent(IN) :: pass ! If matches or not - character(*), intent(IN) :: description ! description of test - - character(4) :: status - - ntests = ntests + 1 - if ( pass )then - npass = npass + 1 - status = "PASS" - else - status = "FAIL" - end if - write(*,formatTest) status, ntests, trim(description) - -end subroutine test_is_logical - -subroutine test_is_logical1D( value, expected, description ) - - implicit none - - logical, intent(IN) :: value(:) ! test value - logical, intent(IN) :: expected(:) ! expected value - character(*), intent(IN) :: description ! description of test - - logical :: pass - integer :: nsize, nmatch - character(256) :: descrip - - nsize = size(value) - if ( all(value .eqv. expected) )then - pass = .true. - write(descrip,formatArrayMatch) nsize - else - nmatch = count(value .eqv. expected) - write(descrip,formatArrayMisMatch) nmatch, nsize - pass = .false. - end if - call test_is_logical( pass, trim(description)//trim(descrip) ) - -end subroutine test_is_logical1D - - -subroutine test_is_string( value, expected, description ) - - implicit none - - character(len=*), intent(IN) :: value - character(len=*), intent(IN) :: expected - character(len=*), intent(IN) :: description ! description of test - - - logical :: pass ! If matches or not - - character(4) :: status - - if ( trim(value) == trim(expected) )then - pass = .true. - else - pass = .false. - end if - ntests = ntests + 1 - if ( pass )then - npass = npass + 1 - status = "PASS" - else - status = "FAIL" - end if - write(*,formatTest) status, ntests, trim(description) - -end subroutine test_is_string - -subroutine test_is_integer( value, expected, description ) - integer, intent(IN) :: value ! test value - integer, intent(IN) :: expected ! expected value - character(*), intent(IN) :: description ! description of test - - logical :: pass - - if ( value == expected )then - pass = .true. - else - pass = .false. - end if - call test_is_logical( pass, description ) - -end subroutine test_is_integer - -subroutine test_is_integer1D( value, expected, description ) - integer, intent(IN) :: value(:) ! test value - integer, intent(IN) :: expected(:) ! expected value - character(*), intent(IN) :: description ! description of test - - logical :: pass - integer :: nsize, nmatch - character(256) :: descrip - - nsize = size(value) - if ( all(value == expected) )then - pass = .true. - write(descrip,formatArrayMatch) nsize - else - nmatch = count(value == expected) - write(descrip,formatArrayMisMatch) nmatch, nsize - pass = .false. - end if - call test_is_logical( pass, trim(description)//trim(descrip) ) - -end subroutine test_is_integer1D - -subroutine test_is_real1D( value, expected, description ) - real(SHR_KIND_R8), intent(IN) :: value(:) ! test value - real(SHR_KIND_R8), intent(IN) :: expected(:) ! expected value - character(*), intent(IN) :: description ! description of test - - logical :: pass - integer :: nsize, nmatch - character(256) :: descrip - - nsize = size(value) - if ( all(value == expected) )then - pass = .true. - write(descrip,formatArrayMatch) nsize - else - nmatch = count(value == expected) - write(descrip,formatArrayMisMatch) nmatch, nsize - pass = .false. - end if - call test_is_logical( pass, trim(description)//trim(descrip) ) - -end subroutine test_is_real1D - -subroutine test_is_real2D( value, expected, description ) - real(SHR_KIND_R8), intent(IN) :: value(:,:) ! test value - real(SHR_KIND_R8), intent(IN) :: expected(:,:) ! expected value - character(*), intent(IN) :: description ! description of test - - logical :: pass - integer :: nsize1, nsize2, nmatch - character(256) :: descrip - - nsize1 = size(value,1) - nsize2 = size(value,2) - if ( all(value == expected) )then - pass = .true. - write(descrip,formatArray2DMatch) nsize1, nsize2 - else - nmatch = count(value == expected) - write(descrip,formatArray2DMisMatch) nmatch, nsize1, nsize2 - pass = .false. - end if - call test_is_logical( pass, trim(description)//trim(descrip) ) - -end subroutine test_is_real2D - -subroutine test_is_realScalar( value, expected, description ) - real(SHR_KIND_R8), intent(IN) :: value ! test value - real(SHR_KIND_R8), intent(IN) :: expected ! expected value - character(*), intent(IN) :: description ! description of test - - logical :: pass - - if ( value == expected )then - pass = .true. - else - pass = .false. - end if - call test_is_logical( pass, description ) - -end subroutine test_is_realScalar - -subroutine test_close_real1D( value, expected, eps, description, rel_diff ) - real(SHR_KIND_R8), intent(IN) :: value(:) ! test value - real(SHR_KIND_R8), intent(IN) :: expected(:) ! expected value - real(SHR_KIND_R8), intent(IN) :: eps ! epsilon -- how close to be within - character(*), intent(IN) :: description ! description of test - logical, optional, intent(IN) :: rel_diff ! if should do relative difference or not - - logical :: pass, lreldiff - integer :: nsize, nmatch, i, n0(1), nf(1) - real(SHR_KIND_R8) :: within, diff - character(256) :: descrip - - lreldiff = .false. - if ( present(rel_diff) ) lreldiff = rel_diff - nsize = size(value) - if ( nsize /= size(expected) )then - call shr_sys_abort( "size of value and expected array is different" ) - end if - if ( any(lbound(value) /= lbound(expected)) )then - call shr_sys_abort( "lower bound of value and expected array is different" ) - end if - nmatch = 0 - n0 = lbound(value) - nf = ubound(value) - within = abs(value(n0(1)) - expected(n0(1))) - if ( lreldiff .and. within > 0.0_SHR_KIND_R8 ) within = within / max( abs(value(n0(1))), abs(expected(n0(1))) ) - do i = n0(1), nf(1) - diff = abs(value(i) - expected(i)) - if ( lreldiff .and. diff > 0.0_SHR_KIND_R8 ) diff = diff / max(abs(value(i)),abs(expected(i)) ) - within = max( within, diff ) - if ( diff <= eps ) nmatch = nmatch + 1 - end do - if( nmatch == nsize )then - write(descrip,formatRArrayClose) nsize, eps - pass = .true. - else - write(descrip,formatRArrayNotClose) nmatch, nsize, eps, within - pass = .false. - end if - call test_is_logical( pass, trim(description)//trim(descrip) ) - -end subroutine test_close_real1D - -subroutine test_close_realScalar( value, expected, eps, description ) - real(SHR_KIND_R8), intent(IN) :: value ! test value - real(SHR_KIND_R8), intent(IN) :: expected ! expected value - real(SHR_KIND_R8), intent(IN) :: eps ! epsilon -- how close to be within - character(*), intent(IN) :: description ! description of test - - logical :: pass - real(SHR_KIND_R8) :: diff - character(256) :: descrip - - diff = abs(value - expected) - if ( diff <= eps ) then - write(descrip,formatRClose) eps - pass = .true. - else - write(descrip,formatRNotClose) eps, diff - pass = .false. - end if - call test_is_logical( pass, trim(description)//trim(descrip) ) - -end subroutine test_close_realScalar - -subroutine test_final( PassStatus ) - - logical, intent(OUT), optional :: PassStatus - - character(4) :: status - character(50) :: desc - - write(*,*) - status = "PASS" - if ( present(PassStatus) ) PassStatus = .true. - desc = "All expected tests ran successfully" - if ( num_expected_given .and. ntests /= num_expected )then - status = "FAIL" - desc = "Different number of tests than expected" - if ( present(PassStatus) ) PassStatus = .false. - end if - if ( npass /= ntests )then - status = "FAIL" - if ( present(PassStatus) ) PassStatus = .false. - write(desc,'(A,i3,A)') "Not all tests passed (", & - ntests-npass, " tests failed)" - end if - write(*,formatTest) status, ntests, "tests run -- "//desc - -end subroutine test_final - -end module test_mod diff --git a/test/old_unit_testers/test_shr_file.F90 b/test/old_unit_testers/test_shr_file.F90 deleted file mode 100644 index dc87e61..0000000 --- a/test/old_unit_testers/test_shr_file.F90 +++ /dev/null @@ -1,220 +0,0 @@ -program test_shr_file -use shr_sys_mod, only: shr_sys_abort, shr_sys_system -use shr_file_mod, only: shr_file_getUnit, shr_file_freeUnit, & - shr_file_chDir, shr_file_chStdIn, shr_file_chStdOut -! -! unit test of the shr_file_mod module -! -write(6,*) 'Test file get/put: ' -call test_getput() - -write(6,*) 'Test units: ' -call test_unit() - -! Test the stdio series of subroutines -write(6,*) 'Test stdio: ' -call test_stdio() - -stop "Tests Pass" - -contains - -subroutine test_stdio() -use shr_sys_mod, only: shr_sys_getenv, shr_sys_chdir -integer, parameter :: nModels = 5 -character(len=3), parameter :: models(nmodels) = (/"atm", "lnd", "ice", "ocn", "cpl"/) -character(len=256) :: nlfile -character(len=256) :: pwd, cwd -character(len=256), parameter :: logfile = "test_shr_file.log" -integer :: i, unit, j -integer :: rcode -logical :: exists -namelist /atm_inparm/ j -namelist /lnd_inparm/ j -namelist /ocn_inparm/ j -namelist /ice_inparm/ j -namelist /cpl_inparm/ j - -call shr_sys_getenv( "pwd", pwd, rcode ) -call shr_sys_system( "/bin/rm "//trim(logfile), rcode ) -do i = 1, nModels - call shr_sys_system( "/bin/rm "//models(i)//".log", rcode ) - if ( i == 1 )then - open(6,file=logfile,status="new") - else - open(6,file=logfile,status="old", position="append") - end if - write(6,*) "test model: ", models(i) - write(6,*) "test chdir: " - call shr_file_chDir(models(i),rcodeOut=rcode) - if ( rcode /= 0 )then - call shr_sys_abort( "error: chDir returns error code" ) - end if - call shr_sys_getenv( "pwd", cwd, rcode ) - !if ( trim(pwd)//"/nl" /= cwd )then - ! write(6,*) 'pwd = ', trim(pwd) - ! write(6,*) 'cwd = ', trim(cwd) - ! call shr_sys_abort( "error: chDir did not go to correct directory" ) - !end if - write(6,*) "test chstdin: " - if ( (models(i) == "atm") .or. (models(i) == "lnd") )then - call shr_file_chStdIn(models(i), NLFilename=nlfile,rcodeOut=rcode) - unit = shr_file_getUnit() - inquire(file=nlfile,exist=exists) - if ( .not. exists )then - call shr_sys_abort( "error: nlfilename does NOT exist: "//trim(nlfile) ) - end if - open(unit,file=trim(nlfile),status="old") - else - call shr_file_chStdIn(models(i),rcodeOut=rcode) - unit = 5 - end if - if ( rcode /= 0 )then - call shr_sys_abort( "error: chstdin returns error code" ) - end if - if ( models(i) == "atm" )then - read(unit,nml=atm_inparm,iostat=rcode) - else if ( models(i) == "lnd" )then - read(unit,nml=lnd_inparm,iostat=rcode) - else if ( models(i) == "ocn" )then - read(unit,nml=ocn_inparm,iostat=rcode) - else if ( models(i) == "ice" )then - read(unit,nml=ice_inparm,iostat=rcode) - else if ( models(i) == "cpl" )then - read(unit,nml=cpl_inparm,iostat=rcode) - end if - close(unit) - if ( rcode /= 0 )then - call shr_sys_abort( "error: reading namelist returns error code" ) - end if - write(6,*) "test chstdout: " - call shr_file_chStdOut(models(i),rcodeOut=rcode) - if ( rcode /= 0 )then - call shr_sys_abort( "error: chstdout returns error code" ) - end if - write(6,*) "<<<<<<<>>>>>>>>>" - call shr_sys_chdir("..",rcode) - close(6) -end do - -end subroutine test_stdio - -subroutine is_prefix( filename, expPrefix, nExpPrefix ) -use shr_file_mod, only: shr_file_queryPrefix, shr_file_noPrefix -character(*), intent(IN) :: filename -character(*), intent(IN) :: ExpPrefix -integer, intent(IN) :: nExpPrefix - -integer :: nPrefix -character(256) :: Prefix - -nPrefix = shr_file_queryPrefix( filename, prefix=prefix ) -if ( nPrefix /= nExpPrefix .or. trim(prefix) /= trim(ExpPrefix) )then - write(6,*) 'Prefix = ', trim(prefix), 'Expected = ', trim(ExpPrefix), " End" - write(6,*) 'N-Prefix = ', nPrefix, 'N-Expected = ', nExpPrefix - call shr_sys_abort( "error: wrong prefix type or wrong returned prefix length" ) -end if - -end subroutine is_prefix - -subroutine test_getput() -use shr_file_mod, only: shr_file_queryPrefix, shr_file_get, shr_file_put, shr_file_noPrefix, & - shr_file_nullPrefix, shr_file_cpPrefix, shr_file_mssPrefix, & - shr_file_hpssPrefix -character(256) :: filename -character(256) :: prefix -integer :: nprefix - - -filename = "/long:directory_d/sub-directory::/file:with_colon.txt" -call is_prefix( filename, "", shr_file_noPrefix ) -filename = "cp:/longdirectory_d/sub-directory::/file:with_colon.txt" -call is_prefix( filename, "cp:", shr_file_cpPrefix ) -filename = "null:/long:directory_d/sub-directory::/file:with_colon.txt" -call is_prefix( filename, "null:", shr_file_nullPrefix ) -filename = "mss:/long:directory_d/sub-directory::/file:with_colon.txt" -call is_prefix( filename, "mss:", shr_file_mssPrefix ) -filename = "hpss:/long:directory_d/sub-directory::/file:with_colon.txt" -call is_prefix( filename, "hpss:", shr_file_hpssPrefix ) -filename = "file:with_colon.txt" -call is_prefix( filename, "", shr_file_noPrefix ) - -end subroutine test_getput - -subroutine test_unit() -integer, parameter :: mxUnits = 89 -integer :: unit(mxUnits) -integer, parameter :: mxRandom = 5 -integer, parameter :: Random(mxRandom) = (/ 4, 36, 91, 92, 95 /) -integer, parameter :: mxTaken = 30 -integer, parameter :: taken(mxTaken) = (/ 3, 9, 11, 21, 23, 25, 28, 30, 33, 35, & - 37, 39, 40, 42, 43, 45, 49, 52, 53, 55, & - 60, 61, 63, 64, 65, 66, 67, 69, 80, 82 /) -integer :: i, j -logical :: opened - -! Test the get unit number routine -do k = 1, 2 ! Loop through this series twice to make sure things ok - ! Open some random unit numbers - do i = 1, mxRandom - call open_file(random(i)) - end do - ! First take a bunch of units with explicit unit numbers - do i = 1, mxTaken - j = shr_file_getUnit( taken(i) ) - call open_file(taken(i)) - if ( j /= taken(i) )then - call shr_sys_abort( "error: get unit did NOT grab the correct unit" ) - end if - end do - ! Now loop through and take all other unit numbers - do i = 1, mxUnits-mxTaken-mxRandom - unit(i) = shr_file_getUnit() - inquire(unit(i), opened=opened ) - if ( opened )then - call shr_sys_abort( "error: get unit got a unit already opened" ) - end if - call open_file(unit(i)) - do j = 1, mxTaken - if ( unit(i) == taken(j) )then - call shr_sys_abort( "error: get unit got a unit already taken" ) - end if - end do - do j = 1, i-1 - if ( unit(i) == unit(j) )then - call shr_sys_abort( "error: get unit got a unit already taken" ) - end if - end do - end do - ! Free units taken - do i = 1, mxUnits-mxTaken-mxRandom - call close_file(unit(i) ) - call shr_file_freeUnit( unit(i) ) - end do - do i = 1, mxTaken - call close_file(taken(i) ) - call shr_file_freeUnit( taken(i) ) - end do - do i = 1, mxRandom - call close_file(random(i)) - end do -end do -end subroutine test_unit - -subroutine open_file(unit) -integer :: unit -character(len=256) :: tmp - -write(6,*) "take unit", unit -write(tmp,"('tmp',i3.3,'.dat')") unit -open(unit, file=tmp, status="new") -end subroutine open_file - -subroutine close_file(unit) -integer :: unit -close(unit,status="delete") -write(6,*) "free unit", unit -end subroutine close_file - - -end program test_shr_file diff --git a/test/old_unit_testers/test_shr_log.F90 b/test/old_unit_testers/test_shr_log.F90 deleted file mode 100644 index 0dde511..0000000 --- a/test/old_unit_testers/test_shr_log.F90 +++ /dev/null @@ -1,28 +0,0 @@ -program test_shr_log - use test_mod, only : test_init, test_final - implicit none - - call test_init - - call test_shr_log_errMsg - - call test_final - -contains - - subroutine test_shr_log_errMsg - use shr_log_mod - use test_mod - - implicit none - - character(len=256) :: my_result - - my_result = shr_log_errMsg('myfile.f90', 42) - - call test_is(my_result, "ERROR in myfile.f90 at line 42", "shr_log_errMsg: basic test") - - end subroutine test_shr_log_errMsg -end program test_shr_log - - diff --git a/test/old_unit_testers/test_shr_mpi.F90 b/test/old_unit_testers/test_shr_mpi.F90 deleted file mode 100644 index 6e47a27..0000000 --- a/test/old_unit_testers/test_shr_mpi.F90 +++ /dev/null @@ -1,291 +0,0 @@ -module test_shr_mpi_mod - use shr_mpi_mod, only: shr_mpi_gathScatVInit, & - shr_mpi_gatherV, & - shr_mpi_scatterv, & - shr_mpi_commrank, & - shr_mpi_chkerr, & - shr_mpi_commsize, & - shr_mpi_send, & - shr_mpi_recv, & - shr_mpi_barrier - use shr_kind_mod, only: r8 => SHR_KIND_R8 - use shr_sys_mod, only: shr_sys_abort - implicit none -#include - - private - - public :: test_gathScat - public :: test_gathScatDiffPES - - contains - -logical function test_gathScat( mpicom, rootid, locArr ) - use shr_kind_mod, only: SHR_KIND_IN - use shr_const_mod, only: SHR_CONST_SPVAL - implicit none - integer(SHR_KIND_IN), intent(IN) :: mpicom - integer(SHR_KIND_IN), intent(IN) :: rootid - real(r8), pointer :: locArr(:) - - real(r8), pointer :: glob1DArr(:), glob1DArrBack(:) - integer(SHR_KIND_IN), pointer :: globSize(:), displs(:) - integer(SHR_KIND_IN), pointer :: globSizeBack(:), displsBack(:) - real(r8), pointer :: locArrBack(:) - integer :: rank, npes, ierr - logical, pointer :: results(:) - - if ( .not. associated(locArr) )then - test_gathScat = .false. - return - end if - allocate( locArrBack(size(locArr)) ) - locArrBack(:) = SHR_CONST_SPVAL - call shr_mpi_gathScatvInit( mpicom, rootid, locArr, glob1DArr, globSize, displs ) - call shr_mpi_gathScatvInit( mpicom, rootid, locArrBack, glob1DArrBack, & - globSizeBack, displsBack ) - call shr_mpi_gatherv( locarr, size(locArr), glob1DArr, globSize, displs, rootid, & - mpicom ) - call shr_mpi_commrank( mpicom, rank ) - call shr_mpi_commsize( mpicom, npes ) - if ( rank == rootid ) glob1DArrBack(:) = glob1DArr(:) - call shr_mpi_scatterv( locarrBack, size(locArrBack), glob1DArrBack, globSizeBack, & - displsBack, rootid, mpicom ) - ! Test that original local array and array from gather/scatter are same - if ( all(locArr == locArrBack) .and. all(locArrBack /= SHR_CONST_SPVAL) )then - test_gathScat = .true. - else - test_gathScat = .false. - end if - ! Now check that global arrays are the same after the gather - if ( rank == rootid .and. test_gathScat ) glob1DArrBack(:) = SHR_CONST_SPVAL - call shr_mpi_gatherv( locarr, size(locArr), glob1DArrBack, globSize, displs, rootid, & - mpicom ) - if ( rank == rootid .and. test_gathScat )then - if ( all(glob1DArr(:) == glob1DArrBack(:)) .and. all(glob1DArrBack(:) /= SHR_CONST_SPVAL) )then - test_gathScat = .true. - else - test_gathScat = .false. - end if - end if - deallocate( glob1DArr, globSize, displs ) - deallocate( glob1DArrBack, globSizeBack, displsBack ) - return -end function test_gathScat - -logical function test_gathScatDiffPES( mpicom, mpicom2, rootid, locArr ) - use shr_kind_mod, only: SHR_KIND_IN - use shr_const_mod, only: SHR_CONST_SPVAL - implicit none - integer(SHR_KIND_IN), intent(IN) :: mpicom - integer(SHR_KIND_IN), intent(IN) :: mpicom2 - integer(SHR_KIND_IN), intent(IN) :: rootid - real(r8), pointer :: locArr(:) - - real(r8), pointer :: glob1DArr(:) - integer(SHR_KIND_IN), pointer :: globSize(:), displs(:) - integer :: rank, npes, ierr, rank2, npes2, nsize, i - integer, pointer :: lsize(:) - logical, pointer :: results(:) - real(r8), pointer :: locArr2(:) - real(r8), pointer :: glob1DArr2(:) - integer(SHR_KIND_IN), pointer :: globSize2(:), displs2(:) - - if ( .not. associated(locArr) )then - test_gathScatDiffPES = .false. - return - end if - ! First gather the local array into a global array that you keep - call shr_mpi_gathScatvInit( mpicom, rootid, locArr, glob1DArr, globSize, displs ) - call shr_mpi_gatherv( locarr, size(locArr), glob1DArr, globSize, displs, rootid, & - mpicom ) - ! Then scatter/gather using the other communicator -- make sure global array identical - call shr_mpi_commrank( mpicom, rank ) - if ( mpicom2 /= MPI_COMM_NULL )then - call shr_mpi_commsize( mpicom2, npes2 ) - ! Figure out size for each local array and send to each processor in group - if ( rank == rootid )then - nsize = size(glob1DArr) / npes2 - allocate( lsize(0:npes2-1) ) - lsize(0:npes2-2) = nsize - lsize(npes2-1) = size(glob1DArr) - sum(lsize(0:npes2-2)) - do i = 1, npes2-1 - write(6,*) "lsize, peid = ", lsize(i), i - call shr_mpi_send( lsize(i), i, 1055, mpicom2 ) - end do - deallocate( lsize ) - else - call shr_mpi_recv( nsize, rootid, 1055, mpicom2 ) - end if - allocate( locArr2(nsize) ) - call shr_mpi_gathScatvInit( mpicom2, rootid, locArr2, glob1DArr2, globSize2, & - displs2 ) - call shr_mpi_scatterv( locarr2, size(locArr2), glob1DArr, globSize2, & - displs2, rootid, mpicom2 ) - glob1DArr2(:) = SHR_CONST_SPVAL - call shr_mpi_gatherv( locarr2, size(locArr2), glob1DArr2, globSize2, displs2, & - rootid, mpicom2 ) - call shr_mpi_commrank( mpicom, rank2 ) - if ( (rank == rootid) .and. (rank2 == rootid) )then - if ( all(glob1DArr(:) == glob1DArr2(:)) .and. & - all(glob1DArr2(:) /= SHR_CONST_SPVAL) )then - test_gathScatDiffPES = .true. - else - test_gathScatDiffPES = .false. - end if - end if - deallocate( glob1DArr2, globSize2, displs2 ) - end if - deallocate( glob1DArr, globSize, displs ) - return -end function test_gathScatDiffPES - -end module test_shr_mpi_mod - -program test_shr_mpi - - use test_shr_mpi_mod, only: test_gathScat, test_gathScatDiffPES - use shr_mpi_mod, only: shr_mpi_init, & - shr_mpi_finalize, & - shr_mpi_commrank, & - shr_mpi_commsize, & - shr_mpi_chkerr, & - shr_mpi_barrier - use shr_kind_mod, only: r8 => SHR_KIND_R8 - use shr_sys_mod, only: shr_sys_abort, shr_sys_flush - implicit none -#include - integer :: mpicom = MPI_COMM_WORLD - integer, parameter :: rootid = 0 - real(r8), pointer :: locArr(:) - integer :: i, gsize, rank, npes, npe1, npe2 - integer, pointer :: seed(:) - integer :: seedSize - character(len=80) :: TestType - real(r8) :: x - logical :: masterproc - integer :: mpicom1, mpicom2 - integer :: mpigrp, mpigrp1, mpigrp2, ierr - - call shr_mpi_init( ) - call shr_mpi_commrank( mpicom, rank ) - call shr_mpi_commsize( mpicom, npes ) - masterproc = rank == rootid - if ( masterproc ) write(6,*) "shr_mpi_mod unit test" - call random_seed( size=seedSize ) - allocate( seed(seedSize) ) - seed(:) = rank*1000 + 1444 - call random_seed( put=seed ) - deallocate( seed ) - ! Get communicators for a subset of the processors - if ( npes > 3 )then - ! Create new groups of 1 and 2 processors - ! Must include rank 0 in both... - call mpi_comm_group( mpicom, mpigrp, ierr ) - call shr_mpi_chkerr( ierr, "Error getting mpi group" ) - call mpi_group_incl( mpigrp, 1, (/0/), mpigrp1, ierr ) - call shr_mpi_chkerr( ierr, "Error getting mpi group-1" ) - call mpi_comm_create( mpicom, mpigrp1, mpicom1, ierr ) - call shr_mpi_chkerr( ierr, "Error creating new comm group with 1 processor" ) - call mpi_group_incl( mpigrp, 2, (/0,2/), mpigrp2, ierr ) - call shr_mpi_chkerr( ierr, "Error getting mpi group-2" ) - call mpi_comm_create( mpicom, mpigrp2, mpicom2, ierr ) - call shr_mpi_chkerr( ierr, "Error creating new comm group with 2 processors" ) - ! Initialize gather/scatter for new communicator groups - call shr_mpi_barrier( mpicom ) - if ( mpicom1 /= MPI_COMM_NULL )then - call shr_mpi_barrier( mpicom1 ) - call shr_mpi_commsize( mpicom1, npe1 ) - if ( npe1 /= 1 ) call shr_sys_abort( "mpicom1 wrong size" ) - end if - if ( mpicom2 /= MPI_COMM_NULL )then - call shr_mpi_barrier( mpicom2 ) - call shr_mpi_commsize( mpicom2, npe2 ) - if ( npe2 /= 2 ) call shr_sys_abort( "mpicom2 wrong size" ) - end if - end if - do i = 1, 4 - if ( i == 1 )then - TestType = "same sizes, random values" - gsize = 10 - call fillArrayRandom( gsize, locArr ) - else if ( i == 2 )then - TestType = "same sizes, ordered values" - gsize = 100 - call fillArrayOrdered( gsize, locArr, rank ) - else if ( i == 3 )then - TestType = "random sizes, random values" - call random_number( x ) - gsize = nint( x*100._r8 ) + 100 - call fillArrayRandom( gsize, locArr ) - else if ( i == 4 )then - TestType = "random sizes, ordered values" - call random_number( x ) - gsize = nint( x*200._r8 ) + 50 - call fillArrayOrdered( gsize, locArr, rank ) - else - call shr_sys_abort( "Bad index number for test" ) - end if - if ( masterproc ) write(6,*) "Gather/scatter test for: ", trim(TestType) - write(6,*) 'rank, size, locarr = ', rank, gsize, locArr - call shr_sys_flush(6) - if ( .not. test_gathScat( mpicom, rootid, locArr ) )then - call shr_sys_abort( "Error in doing scatter/gather" ) - end if - call shr_mpi_barrier( mpicom ) - if ( masterproc ) write(6,*) "PASS" - if ( npes > 3 )then - if ( masterproc ) write(6,*) "Gather/scatter test on mpicom1 for: ", trim(TestType) - call shr_sys_flush(6) - if ( .not. test_gathScatDiffPES( mpicom, mpicom1, rootid, locArr ) )then - call shr_sys_abort( "Error in reconstructing array with mpicom1" ) - end if - call shr_mpi_barrier( mpicom ) - if ( masterproc ) write(6,*) "PASS" - call shr_mpi_barrier( mpicom ) - if ( masterproc ) write(6,*) "PASS" - if ( masterproc ) write(6,*) "Gather/scatter test on mpicom2 for: ", trim(TestType) - call shr_sys_flush(6) - if ( .not. test_gathScatDiffPES( mpicom, mpicom2, rootid, locArr ) )then - call shr_sys_abort( "Error in reconstructing array with mpicom2" ) - end if - call shr_mpi_barrier( mpicom ) - if ( masterproc ) write(6,*) "PASS" - end if - deallocate( locArr ) - end do - call shr_mpi_finalize( ) - if ( masterproc ) write(6,*) "SUCCESS!" - if ( masterproc ) write(6,*) "PASS" - -contains - -subroutine fillArrayRandom( gsize, locArr ) - integer, intent(in) :: gsize - real(r8), pointer :: locArr(:) - - real(r8) :: x - integer :: g - - allocate( locArr(gsize) ) - do g = 1, gsize - call random_number( x ) - locArr(g) = x * 1000.0_r8 - end do -end subroutine fillArrayRandom - -subroutine fillArrayOrdered( gsize, locArr, rank ) - integer, intent(in) :: gsize - integer, intent(in) :: rank - real(r8), pointer :: locArr(:) - - real(r8) :: x - integer :: g - - allocate( locArr(gsize) ) - do g = 1, gsize - locArr(g) = real( g, r8 ) + rank*1000.0_r8 - end do -end subroutine fillArrayOrdered - -end program test_shr_mpi diff --git a/test/old_unit_testers/test_shr_orb.F90 b/test/old_unit_testers/test_shr_orb.F90 deleted file mode 100644 index 85f9e25..0000000 --- a/test/old_unit_testers/test_shr_orb.F90 +++ /dev/null @@ -1,47 +0,0 @@ - program test_shr_orb -! -! Simple unit-test program for the shr_orb_mod module. -! -! Erik Kluzek -! -! $Id: test_shr_orb.F90 7482 2007-11-07 20:54:58Z erik $ -! - use shr_kind_mod, only: SHR_KIND_R8, SHR_KIND_IN - use shr_orb_mod, only: shr_orb_cosz, shr_orb_params, shr_orb_decl, shr_orb_print - implicit none - integer, parameter :: nyears = 5 - integer, parameter :: ndays = 5 - real (SHR_KIND_R8), parameter :: jday(ndays) = & - (/ 0.0_SHR_KIND_R8, 0.25_SHR_KIND_R8, 0.5_SHR_KIND_R8, 180.0_SHR_KIND_R8, 365.0_SHR_KIND_R8 /) ! Julian cal day (1.xx to 365.xx) - real (SHR_KIND_R8) :: lat = 42.0_SHR_KIND_R8 ! Centered latitude (radians) - real (SHR_KIND_R8) :: lon = 0.0_SHR_KIND_R8 ! Centered longitude (radians) - real (SHR_KIND_R8) :: declin ! Solar declination (radians) - real (SHR_KIND_R8) :: eccen ! orbital eccentricity - real (SHR_KIND_R8) :: obliq ! obliquity in degrees - real (SHR_KIND_R8) :: mvelp ! moving vernal equinox long - integer(SHR_KIND_IN), parameter :: iyear_AD(nyears) = & - (/-900000, -1650, 1950, 3600, 1000000/) - logical :: log_print = .true. ! Flags print of status/error - real (SHR_KIND_R8) :: obliqr ! Earths obliquity in rad - real (SHR_KIND_R8) :: lambm0 ! Mean long of perihelion at - ! vernal equinox (radians) - real (SHR_KIND_R8) :: mvelpp ! moving vernal equinox long - ! of perihelion plus pi (rad) - real (SHR_KIND_R8) :: cosz ! cosine of solar zenith angle - real (SHR_KIND_R8) :: eccf ! Earth-sun distance factor - integer i, j ! Indices - - print *, 'Test orbit calculation for ', nyears, ' years and ', ndays, ' days ' - do i = 1, nyears - call shr_orb_params( iyear_AD(i) , eccen , obliq , mvelp , & - & obliqr , lambm0 , mvelpp, log_print ) - call shr_orb_print( iyear_AD(i), eccen, obliq, mvelp ) - do j = 1, ndays - call shr_orb_decl(jday(j),eccen ,mvelpp ,lambm0 ,obliqr ,declin,eccf) - cosz = shr_orb_cosz(jday(j),lat,lon,declin) - print *, 'jday = ', jday(j), ' declin = ', declin, ' cosz = ', cosz - end do - end do - print *, 'PASS' - - end program test_shr_orb diff --git a/test/old_unit_testers/test_shr_scam.F90 b/test/old_unit_testers/test_shr_scam.F90 deleted file mode 100644 index 5302be4..0000000 --- a/test/old_unit_testers/test_shr_scam.F90 +++ /dev/null @@ -1,156 +0,0 @@ -program test_shr_scam - - use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_CL - use shr_scam_mod - use shr_mpi_mod - use shr_sys_mod - use shr_ncread_mod - use test_mod - use netcdf - use pio - implicit none -#include - - real(r8) :: targetLat, targetLon ! target latitude/longitude - real(r8) :: closeLat, closeLon ! close latitude/longitude - real(r8) :: expect(2) ! lat lon of expected - integer :: closeLatIdx, closeLonIdx ! indices of returned points - integer :: rc ! return code - integer :: ncid ! NetCDF id - integer :: npes, mype ! number of processors and my processor rank - character(len=CL) :: filename ! Filename to read - character(len=CL) :: badfilename ! bad Filename to read - character(len=CL) :: csmdata ! directory to inputdata - type(file_desc_t) :: pioid ! pio file ID - type (iosystem_desc_t), pointer :: piosystems - logical :: found ! if found or NOT - - call test_init( 22 ) - - ! Test simple valid tests - csmdata = "/fs/cgd/csm/inputdata" - filename = trim(csmdata)//"/lnd/clm2/surfdata/surfdata_1.9x2.5_simyr2000_c100505.nc" - write(6,*) "Test file: "//trim(filename) - targetLat = 45.0 - targetLon = 180.0 - expect = (/ 44.5263157894736d00, targetLon /) - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found ) - write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & - closeLat, closeLon - call test_is( found, "Test that a a simple call with filename works" ) - call test_close( expect, (/ closeLat, closeLon /), 1.e-13_r8, "Test lat/lon found correct" ) - expect = (/ closeLat, closeLon /) - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx ) - call test_is( expect, (/ closeLat, closeLon /), "Test OK without found" ) - rc = nf90_open( filename, NF90_NOWRITE, ncid ) - if ( rc /= NF90_NOERR ) call shr_sys_abort( "NetCDF error opening file: "//trim(filename) ) - call shr_scam_getCloseLatLon( ncid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found ) - - call test_is( found, "Test that a a simple call to NetCDF id works" ) - call test_is( expect, (/ closeLat, closeLon /), "Test lat/lon found correct" ) - call shr_scam_getCloseLatLon( ncid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx ) - call test_is( expect, (/ closeLat, closeLon /), "Test OK without found" ) - - if ( nf90_close( ncid ) /= NF90_NOERR ) call shr_sys_abort( "NetCDF error closing file" ) - write(6,*) "init mpi" - call shr_mpi_init( ) - call shr_mpi_commsize( MPI_COMM_WORLD, npes ) - call shr_mpi_commrank( MPI_COMM_WORLD, mype ) - write(6,*) "init PIO" - allocate( piosystems ) - call PIO_init(mype, MPI_COMM_WORLD, npes, 1, 1, pio_rearr_box, piosystems, base=0) - - rc = pio_openfile(piosystems, pioid, iotype_netcdf, filename, pio_nowrite) - if(rc/= PIO_NOERR) call shr_sys_abort( "PIO error opening file: "//trim(filename) ) - write(6,*) "PIO open on file" - call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found ) - - call test_is( found, "Test that a a simple call to the PIO interface works" ) - call test_is( expect, (/ closeLat, closeLon /), "Test lat/lon found correct" ) - call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx ) - call test_is( expect, (/ closeLat, closeLon /), "Test OK without found" ) - call pio_closefile(pioid) - - ! Test that can find periodic longitudes - targetLat = 1.0 - targetLon = 842.0 - expect = (/ 0.947368421052549d00, 122.5d00 /) - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( found, "Test that periodic longitude targets returns" ) - write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & - closeLat, closeLon - call test_close( expect, (/ closeLat, closeLon /), 1.e-13_r8, "Test lat/lon found correct" ) - expect = (/ closeLat, closeLon /) - filename = trim(csmdata)// & - "/lnd/clm2/initdata/clmi.BCN.2000-01-01_1.9x2.5_gx1v6_simyr2000_c100309.nc" - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( found, "Test that can find targets for clmi file" ) - call test_close( expect, (/ closeLat, closeLon /), 1.d-13, & - "Test that clmi targets same as other file" ) - ! Test abort tests - ! non-existant filename - call shr_ncread_setAbort( .false. ) - badfilename = "ZZTop.nc" - call shr_scam_getCloseLatLon( badfilename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that non existant file returns NOT found" ) - call shr_scam_getCloseLatLon( ncid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that non existant NetCDF ID returns NOT found" ) - call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that non existant PIO ID returns NOT found" ) - ! Test that targets outside of global lat/lons return not found - targetLat = -91.0 - targetLon = 0.0 - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that bad negative lat returns NOT found" ) - if ( found ) then - write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & - closeLat, closeLon - end if - targetLat = +91.0 - targetLon = 0.0 - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that bad positive lat returns NOT found" ) - if ( found ) then - write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & - closeLat, closeLon - end if - targetLat = 45. - targetLon = 180. - filename = trim(csmdata)// & - "/lnd/clm2/snicardata/snicar_optics_5bnd_c090915.nc" - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that can NOT find targets for snicar optics file" ) - filename = trim(csmdata)// & - "/lnd/clm2/pftdata/pft-physiology.c110425.nc" - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that can NOT find targets for pft-phys file" ) - filename = trim(csmdata)// & - "/lnd/clm2/mappingdata/maps/10x15/map_0.5x0.5_landuse_to_10x15_aave_da_110307.nc" - call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call test_is( .not. found, "Test that can NOT find targets for mapping file" ) - rc = pio_openfile(piosystems, pioid, iotype_netcdf, filename, pio_nowrite) - if(rc/= PIO_NOERR) call shr_sys_abort( "PIO error opening file: "//trim(filename) ) - call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & - closeLatIdx, closeLonIdx, found=found, rc=rc ) - call pio_closefile(pioid) - call test_is( .not. found, "Test that can NOT find targets for PIO clmi file" ) - - call test_final() - -end diff --git a/test/old_unit_testers/test_shr_streams.F90 b/test/old_unit_testers/test_shr_streams.F90 deleted file mode 100644 index 1e4bb15..0000000 --- a/test/old_unit_testers/test_shr_streams.F90 +++ /dev/null @@ -1,663 +0,0 @@ -module streams_exp - use shr_kind_mod, only : SHR_KIND_CS, SHR_KIND_CL, SHR_KIND_CX - use shr_sys_mod, only : shr_sys_abort - use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit - use shr_stream_mod - - implicit none - - private - - public streams_exp_init - public streams_exp_set - public streams_exp_write_strm_txt - public is_streams_expected - - public streams_exp_data - - integer, public, parameter :: maxFiles = 2000 - - type streams_exp_data - character(SHR_KIND_CL) :: dataSource - character(SHR_KIND_CL) :: filePath - character(SHR_KIND_CX) :: fldListFile - character(SHR_KIND_CX) :: fldListModel - character(SHR_KIND_CL) :: domFilePath - character(SHR_KIND_CL) :: domFileName - character(SHR_KIND_CL) :: domTvarName - character(SHR_KIND_CL) :: domXvarName - character(SHR_KIND_CL) :: domYvarName - character(SHR_KIND_CL) :: domAreaName - character(SHR_KIND_CL) :: domMaskName - integer :: nfiles - character(SHR_KIND_CL) :: filenames(maxFiles) - end type streams_exp_data - -contains - -subroutine streams_exp_init( streams_exp ) - implicit none - type(streams_exp_data), intent(OUT) :: streams_exp - - integer :: i - - streams_exp%dataSource = "dataSource" - streams_exp%filePath = "filePath/" - streams_exp%fldListFile = "T:U" - streams_exp%fldListModel = "Temp:Wind_u" - streams_exp%domFilePath = "domFilePath/" - streams_exp%domFileName = "domFileName" - streams_exp%domTvarName = "time" - streams_exp%domXvarName = "xc" - streams_exp%domYvarName = "yc" - streams_exp%domAreaName = "area" - streams_exp%domMaskName = "mask" - streams_exp%nfiles = 1 - do i = 1, streams_exp%nfiles - write(streams_exp%filenames(i), '(a,i2.2)') "filename", i - end do -end subroutine streams_exp_init - -subroutine streams_exp_set( streams_exp, datasource, filePath, fldListfile, & - fldListModel, domFilePath, domFileName, domTvarName, & - domXvarName, domYvarName, domAreaName, domMaskName, & - nfiles, filenames ) - implicit none - type(streams_exp_data), intent(INOUT) :: streams_exp - character(*), intent(IN), optional :: dataSource - character(*), intent(IN), optional :: filePath - character(*), intent(IN), optional :: fldListFile - character(*), intent(IN), optional :: fldListModel - character(*), intent(IN), optional :: domFilePath - character(*), intent(IN), optional :: domFileName - character(*), intent(IN), optional :: domTvarName - character(*), intent(IN), optional :: domXvarName - character(*), intent(IN), optional :: domYvarName - character(*), intent(IN), optional :: domAreaName - character(*), intent(IN), optional :: domMaskName - integer , intent(IN), optional :: nfiles - character(*), intent(IN), optional :: filenames(:) - - integer :: i - - if ( present(dataSource) ) streams_exp%dataSource = datasource - if ( present(filePath) ) streams_exp%filePath = filePath - if ( present(fldListFile) ) streams_exp%fldListFile = fldListFile - if ( present(fldListModel) ) streams_exp%fldListModel = fldListModel - if ( present(domFilePath) ) streams_exp%domFilePath = domFilePath - if ( present(domFileName) ) streams_exp%domFileName = domFileName - if ( present(domTvarName) ) streams_exp%domTvarName = domTvarName - if ( present(domXvarName) ) streams_exp%domXvarName = domXvarName - if ( present(domYvarName) ) streams_exp%domYvarName = domYvarName - if ( present(domAreaName) ) streams_exp%domAreaName = domAreaName - if ( present(domMaskName) ) streams_exp%domMaskName = domMaskName - if ( present(nfiles) .and. present(filenames) )then - streams_exp%nfiles = nfiles - do i = 1, streams_exp%nfiles - streams_exp%filenames(i) = filenames(i) - end do - end if - -end subroutine streams_exp_set - - -subroutine streams_exp_write_strm_txt( stream_filename, streams_exp ) - use shr_string_mod, only : shr_string_listGetNum, shr_string_listGetName - use shr_sys_mod, only : shr_sys_system - implicit none - character(SHR_KIND_CL), intent(IN) :: stream_filename - type(streams_exp_data), intent(IN) :: streams_exp - - integer :: unit, n, rcode, nfModel, nfFile - character(SHR_KIND_CS) :: varModel, varFile - character(*), parameter :: sub = "write_streams_txt" - - unit = shr_file_getUnit( ) - write(*,*) "Write streams text file out to: ", trim(stream_filename) - open( unit, file=stream_filename, status="unknown") - - write(unit,*) "" - write(unit,*) " ", trim(streams_exp%dataSource) - write(unit,*) "" - write(unit,*) "" - write(unit,*) " " - write(unit,*) " ", trim(streams_exp%domTvarName), " time" - write(unit,*) " ", trim(streams_exp%domXvarName), " lon" - write(unit,*) " ", trim(streams_exp%domYvarName), " lat" - write(unit,*) " ", trim(streams_exp%domAreaName), " area" - write(unit,*) " ", trim(streams_exp%domMaskName), " mask" - write(unit,*) " " - write(unit,*) " " - write(unit,*) " ", trim(streams_exp%domFilePath) - write(unit,*) " " - write(unit,*) " " - write(unit,*) " ", trim(streams_exp%domFileName) - write(unit,*) " " - write(unit,*) "" - write(unit,*) "" - write(unit,*) " " - nfModel = shr_string_listGetNum( streams_exp%fldListModel ) - nfFile = shr_string_listGetNum( streams_exp%fldListFile ) - do n = 1, max( nfModel, nfFile ) - if ( n > nfFile ) then - varFile = " " - else - call shr_string_listGetName(streams_exp%fldListFile, n, varFile ) - end if - if ( n > nfModel ) then - varModel = " " - else - call shr_string_listGetName(streams_exp%fldListModel, n, varModel ) - end if - write(unit,*) & - " ", trim(varFile), " ", & - " ", trim(varModel) - end do - write(unit,*) " " - write(unit,*) " " - write(unit,'(A,A)') " ", trim(streams_exp%FilePath) - write(unit,*) " " - write(unit,*) " " - do n = 1, streams_exp%nfiles - write(unit,*) & - " ", trim(streams_exp%filenames(n)) - end do - write(unit,*) " " - write(unit,*) "" - close(unit) - call shr_file_freeUnit(unit) - call shr_sys_system( "cat "//trim(stream_filename), rcode ) - -end subroutine streams_exp_write_strm_txt - -logical function is_streams_expected( stream, streams_exp ) - implicit none - type(shr_stream_streamType) ,intent(in) :: stream ! stream in question - type(streams_exp_data), intent(IN) :: streams_exp - - character(SHR_KIND_CL) :: dataSource - character(SHR_KIND_CL) :: filePath - character(SHR_KIND_CX) :: fldListFile - character(SHR_KIND_CX) :: fldListModel - character(SHR_KIND_CL) :: domFilePath - character(SHR_KIND_CL) :: domFileName - character(SHR_KIND_CL) :: domTvarName - character(SHR_KIND_CL) :: domXvarName - character(SHR_KIND_CL) :: domYvarName - character(SHR_KIND_CL) :: domAreaName - character(SHR_KIND_CL) :: domMaskName - character(SHR_KIND_CL) :: filen, file_next, file_first - integer :: n - - is_streams_expected = .true. - - call shr_stream_getFileFieldList( stream, fldlistFile ) - call shr_stream_getModelFieldList( stream, fldlistModel ) - call shr_stream_getFilePath( stream, filePath ) - call shr_stream_getDataSource( stream, dataSource ) - call shr_stream_getDomainInfo( stream, domFilePath, domfileName, & - domTvarName, domXvarName, domYvarName, & - dommaskName, domareaName) - if ( trim(fldListFile) /= trim(streams_exp%fldListFile) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "fldListFile different" - if ( .not. is_streams_expected )then - write(*,*) trim(fldListFile) - write(*,*) trim(streams_exp%fldListFile) - end if - if ( trim(fldListModel) /= trim(streams_exp%fldListModel) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "fldListModel different" - if ( trim(filePath) /= trim(streams_exp%filePath) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "filePath different" - if ( trim(dataSource) /= trim(streams_exp%dataSource) ) & - is_streams_expected = .false. - if ( trim(domFilePath) /= trim(streams_exp%domFilePath) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domfilePath different" - if ( trim(domFileName) /= trim(streams_exp%domFileName) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domfileName different" - if ( trim(domTvarName) /= trim(streams_exp%domTvarName) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domTvarName different" - if ( trim(domXvarName) /= trim(streams_exp%domXvarName) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domXvarName different" - if ( trim(domYvarName) /= trim(streams_exp%domYvarName) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domYvarName different" - if ( trim(domAreaName) /= trim(streams_exp%domAreaName) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domAreaName different" - if ( trim(domMaskName) /= trim(streams_exp%domMaskName) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "domMaskName different" - n = 1 - call shr_stream_getFirstFileName( stream, filen ) - file_first = filen - if ( trim(filen) /= trim(streams_exp%filenames(1)) ) is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "first file different" - do while( n < streams_exp%nfiles ) - n = n + 1 - call shr_stream_getNextFileName( stream, filen, file_next ) - if ( trim(file_next) /= trim(streams_exp%filenames(n)) ) & - is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "next file different" - if ( trim(file_next) == trim(file_first) ) is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "Too few files" - filen = file_next - end do - call shr_stream_getNextFileName( stream, filen, file_next ) - if ( trim(file_next) /= trim(file_first) ) is_streams_expected = .false. - if ( .not. is_streams_expected ) write(*,*) "too many files" - -end function is_streams_expected - -end module streams_exp - -program test_shr_streams - - use shr_kind_mod - use shr_string_mod - use shr_sys_mod - use shr_stream_mod - use streams_exp - use test_mod - - implicit none - - type(shr_stream_streamType), pointer :: streams(:) ! stream in question - type(shr_stream_streamType), pointer :: streams2(:) ! stream in question - integer :: yearFirst, yearLast, yearAlign - character(SHR_KIND_CL) :: stream_filename = "sfile.txt" - character(SHR_KIND_CL) :: rest_filename = "sfile_rest.nc" - character(SHR_KIND_CL) :: test_descrip, filenames1(maxFiles) - type(streams_exp_data) :: stream_exp ! stream in question - integer :: series, n, i - integer, pointer :: expected(:), value(:) - character(SHR_KIND_CS) :: clmncep(12) = (/ & - "clmforc.Qian.c2006.T62.Solr.2003-01.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-02.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-03.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-04.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-05.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-06.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-07.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-08.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-09.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-10.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-11.nc", & - "clmforc.Qian.c2006.T62.Solr.2003-12.nc" & - /) - character(SHR_KIND_CS) :: clmncepTPQW(12) = (/ & - "clmforc.Qian.c2006.T62.TPQW.2003-01.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-02.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-03.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-04.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-05.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-06.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-07.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-08.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-09.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-10.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-11.nc", & - "clmforc.Qian.c2006.T62.TPQW.2003-12.nc" & - /) - character(SHR_KIND_CS) :: filenames2(12) - integer :: mDateIn, SecIn, year, month, rcode, exp_int, nfiles - integer :: mDateLB, dDateLB, secLB, n_lb - integer :: mDateUB, dDateUB, secUB, n_ub - character(SHR_KIND_CL) :: fileLB, fileUB - integer :: num_series, num_fail - integer, parameter :: bogus_TEST = 1, & - CLMNCEP_TEST = 2, & - CLMNCEP_ALOGO_TEST = 3, & - GISS_TEST = 4, & - CAMHIST_TEST = 5 - -#ifdef LINUX - num_series = CLMNCEP_ALOGO_TEST -#else - num_series = CAMHIST_TEST -#endif - num_fail = 3 + 12 - call test_init( 2 + (num_series-1)*3 + num_fail ) - do series = 2, num_series - yearAlign = 1 - yearFirst = 1 - yearLast = 1 - allocate( streams(1) ) - allocate( streams2(1) ) - write(*,*) "Initialize expected streams" - call streams_exp_init( stream_exp ) - if ( series == bogus_TEST )then - test_descrip = "bogus" - else if ( series == CLMNCEP_TEST )then - test_descrip = "CLMNCEP" - call streams_exp_set( stream_exp, datasource="CLMNCEP", & - fldListfile ="FSDS", & - fldListModel="fsds", & - filepath= & - "/fs/cgd/csm/inputdata/atm/datm7/atm_forcing.datm7.Qian.T62.c080727/Solar6Hrly", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & - domfilename="domain.T62.050609.nc", & - nfiles=12, filenames=clmncep(1:12) ) - yearAlign = 2003 - yearFirst = 2003 - yearLast = 2003 - else if ( series == CLMNCEP_ALOGO_TEST )then - test_descrip = "CLMNCEP-ALOGO" - call streams_exp_set( stream_exp, datasource="CLMNCEP", & - fldListfile ="TBOT:QBOT:WIND:PSRF", & - fldListModel="tbot:qbot:wind:psrf", & - filepath=& - "/fs/cgd/csm/inputdata/atm/datm7/atm_forcing.datm7.Qian.T62.c080727/TmpPrsHumWnd3Hrly", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & - domfilename="domain.T62.050609.nc", & - nfiles=12, filenames=clmncepTPQW(1:12) ) - yearAlign = 1 - yearFirst = 2003 - yearLast = 2003 -#ifndef LINUX - else if ( series == GISS_TEST )then - test_descrip = "GISS" - call streams_exp_set( stream_exp, datasource="GISS", & - fldListfile = "lwdn:swdn:swup", & - fldListModel= "lwdn:swdn:swup", & - filepath="/fs/cgd/csm/inputdata/atm/datm7/TN460/", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/TN460/", & - domXvarName="lon", & - domYvarName="lat", & - domfilename="tn460nyf.giss.T62.051007.nc", & - nfiles=1, filenames=(/ "tn460nyf.giss.T62.051007.nc" /) ) - else if ( series == CAMHIST_TEST )then - test_descrip = "CAMHIST" - yearAlign = 5 - yearFirst = 5 - yearLast = 6 - call streams_exp_set( stream_exp, datasource="CAMHIST", & - fldListfile = & - "FSNS:PRECC:PRECL:PRECSC:PRECSL:PS:PSL:QBOT:SOLL:SOLLD:SOLS:SOLSD:SRFRAD:FSNS:TBOT:UBOT:VBOT:ZBOT", & - fldListModel= & - "swnet:precc:precl:snowc:snowl:ps:pslv:shum:swndr:swndf:swvdr:swvdf:srfrad:swnet:tbot:u:v:z", & - filepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & - domfilename="domain.T42.050516.nc", & - nfiles=2, filenames=(/ & - "eul64x128_datm6.01.cam2.h1.0005-01-01-00000.nc", & - "eul64x128_datm6.01.cam2.h1.0006-01-01-00000.nc" & - /) ) -#endif - end if - write(*,*) "Write streams out to file" - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - write(*,*) "Initialize shr_streams" - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign ) - if ( series > 1 )then - write(*,*) "Get time bounds..." - secIn = 0 - write(*,*) "mDateIn, SecIn, mDateLB,mDateUB, dDateLB,dDateUB, secLB, secUB" - allocate( expected((yearLast-yearFirst+3)*12) ) - allocate( value((yearLast-yearFirst+3)*12) ) - n = 0 - do year = yearAlign-1, yearAlign+1+(yearLast-yearFirst) - do month = 1, 12 - n = n + 1 - mDateIn = year * 10000 + month*100 + 1 - call shr_stream_findBounds(streams(1),mDateIn, secIn, & - & mDateLB,dDateLB,secLB,n_lb,fileLB, & - & mDateUB,dDateUB,secUB,n_ub,fileUB ) - if ( year < yearFirst )then - expected(n) = yearLast * 10000 + month*100 + 1 - else if ( year > yearLast )then - expected(n) = yearFirst * 10000 + month*100 + 1 - else - expected(n) = year * 10000 + month*100 + 1 - end if - if ( series == CAMHIST_TEST ) expected(n) = expected(n) + 1 - value(n) = dDateUB - write(6,'(8i9)') mDateIn, SecIn, mDateLB,mDateUB, dDateLB,dDateUB, & - secLB, secUB - end do - end do - call test_is( value, expected, " test if expected values") - deallocate( expected ) - deallocate( value ) - end if - call shr_stream_dataDump( streams(1) ) - write(*,*) "Check if it is as expected..." - call test_is( is_streams_expected( streams(1), stream_exp ), & - "test if initialization is what expected "//trim(test_descrip) ) - write(*,*) "Write restart file out" - call shr_stream_restWrite( streams, rest_filename, caseName="clmrun", & - caseDesc="clmrun description" ) - write(*,*) "Read that file into a different stream" - call shr_stream_init( streams2(1), stream_filename, yearFirst, yearLast, yearAlign ) - call shr_stream_restRead( streams2, rest_filename ) - write(*,*) "Check if read restart is as expected..." - call test_is( is_streams_expected( streams2(1), stream_exp ), & - "test after read restart "//trim(test_descrip) ) - deallocate( streams ) - deallocate( streams2 ) - call shr_sys_system( "/bin/rm -f "//trim(stream_filename), rcode ) - call shr_sys_system( "/bin/rm -f "//trim(rest_filename), rcode ) - end do - - ! Fail tests - call shr_stream_setAbort( .false. ) - call shr_string_setAbort( .false. ) - allocate( streams(1) ) - allocate( streams2(1) ) - - write(*,*) "Try to write uninitialized stream out" - call shr_stream_restWrite( streams, rest_filename, caseName="clmrun", & - caseDesc="clmrun description", rc=rcode ) - call test_is( rcode, 1, "test that writing uninitialized stream fails" ) - - write(*,*) "Try to read uninitialized stream in" - call shr_stream_restRead( streams2, rest_filename, rc=rCode ) - call test_is( rcode, 1, "test that reading uninitialized stream fails" ) - - mDateIn = 20000101 - write(*,*) "Try to find bounds on uninitialized stream" - call shr_stream_findBounds(streams(1),mDateIn, secIn, & - & mDateLB,dDateLB,secLB,n_lb,fileLB, & - & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) - call test_is( rcode, 1, "test that find bounds of uninitialized stream fails" ) - - - do series = 1, 99 - yearAlign = 1 - yearFirst = 1 - yearLast = 1 - call streams_exp_init( stream_exp ) - if ( series == 1 )then - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign ) - test_descrip = "Try to read restart file that does not exist" - call shr_sys_system( "/bin/rm -f "//trim(rest_filename), rcode ) - call shr_stream_restRead( streams, rest_filename, rc=rCode ) - exp_int = 2 - else if ( series == 2 )then - test_descrip = "Try to initialize streams with too many files" - nfiles = 1001 - do i = 1, nfiles - write(filenames1(i),'("filename",i4.4,".nc")' ) i - end do - call streams_exp_set( stream_exp, datasource="CAMHIST", & - fldListfile = & - "FSNS:PRECC:PRECL:PRECSC:PRECSL:PS:PSL:QBOT:SOLL:SOLLD:SOLS:SOLSD:SRFRAD:FSNS:TBOT:UBOT:VBOT:ZBOT", & - fldListModel= & - "swnet:precc:precl:snowc:snowl:ps:pslv:shum:swndr:swndf:swvdr:swvdf:srfrad:swnet:tbot:u:v:z", & - filepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & - domfilename="domain.T42.050516.nc", & - nfiles=nfiles, filenames=filenames1(1:nfiles) ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 3 )then - test_descrip = "variable name lists do not have same number of values" - call streams_exp_set( stream_exp, datasource="CLMNCEP", & - fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & - fldListModel="tbot:qbot:wind:prectMMS", & - filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & - domfilename="domain.T62.050609.nc", & - nfiles=12, filenames=clmncep(1:12) ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 4 )then - test_descrip = "Mask name set to blank" - call streams_exp_set( stream_exp, domMaskName=" " ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 5 )then - test_descrip = "Area name set to blank" - call streams_exp_set( stream_exp, domAreaName=" " ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 6 )then - test_descrip = "Yvar name set to blank" - call streams_exp_set( stream_exp, domYVarName=" " ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 7 )then - test_descrip = "Xvar name set to blank" - call streams_exp_set( stream_exp, domXVarName=" " ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 8 )then - test_descrip = "tvar name set to blank" - call streams_exp_set( stream_exp, domTVarName=" " ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 9 )then - test_descrip = "no filenames" - call streams_exp_set( stream_exp, nfiles=0, filenames=(/" "/) ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 10 )then - test_descrip = "no fieldnames" - call streams_exp_set( stream_exp, fldListfile ="", fldListModel="" ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - exp_int = 1 - else if ( series == 11 )then - test_descrip = "Dates are out of range" - call streams_exp_set( stream_exp, datasource="CLMNCEP", & - fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & - fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & - filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & - domfilename="domain.T62.050609.nc", & - nfiles=12, filenames=clmncep(1:12) ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - yearAlign = 1948 - yearFirst = 1952 - yearLast = 1952 - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign ) - secIn = 0 - mDateIn = yearAlign * 10000 + 12*100 + 1 - call shr_stream_findBounds(streams(1),mDateIn, secIn, & - & mDateLB,dDateLB,secLB,n_lb,fileLB, & - & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) - exp_int = 1 - else if ( series == 12 )then - test_descrip = "One file is out of sequence" - filenames2 = clmncep - filenames2(2) = clmncep(4) - filenames2(4) = clmncep(2) - call streams_exp_set( stream_exp, datasource="CLMNCEP", & - fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & - fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & - filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & - domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & - domfilename="domain.T62.050609.nc", & - nfiles=12, filenames=filenames2 ) - call streams_exp_write_strm_txt( stream_filename, stream_exp ) - yearAlign = 1948 - yearFirst = 1948 - yearLast = 1948 - call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & - yearAlign, rc=rCode ) - secIn = 0 - mDateIn = yearAlign * 10000 + 12*100 + 1 - call shr_stream_findBounds(streams(1),mDateIn, secIn, & - & mDateLB,dDateLB,secLB,n_lb,fileLB, & - & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) - exp_int = 1 -! else if ( series == 12 )then -! test_descrip = "year range is out of bounds" -! call streams_exp_set( stream_exp, datasource="CLMNCEP", & -! fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & -! fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & -! filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & -! domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & -! domfilename="domain.T62.050609.nc", & -! nfiles=12, filenames=clmncep(1:12) ) -! yearAlign = 1948 -! yearFirst = 1948 -! yearLast = 1972 -! call streams_exp_write_strm_txt( stream_filename, stream_exp ) -! call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign, rCode ) -! secIn = 0 -! mDateIn = yearAlign * 10000 + 12*100 + 1 -! call shr_stream_findBounds(streams(1),mDateIn, secIn, & -! & mDateLB,dDateLB,secLB,n_lb,fileLB, & -! & mDateUB,dDateUB,secUB,n_ub,fileUB ) -! exp_int = 1 -! else if ( series == 13 )then -! test_descrip = "Dates are backwards" -! call streams_exp_set( stream_exp, datasource="CLMNCEP", & -! fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & -! fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & -! filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & -! domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & -! domfilename="domain.T62.050609.nc", & -! nfiles=12, filenames=clmncep(12:1:-1) ) -! call streams_exp_write_strm_txt( stream_filename, stream_exp ) -! yearAlign = 1948 -! yearFirst = 1948 -! yearLast = 1948 -! call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign, rCode ) -! secIn = 0 -! mDateIn = yearAlign * 10000 + 12*100 + 1 -! call shr_stream_findBounds(streams(1),mDateIn, secIn, & -! & mDateLB,dDateLB,secLB,n_lb,fileLB, & -! & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) -! exp_int = 1 - else - exit - end if - write(*,*) trim(test_descrip) - call test_is( rcode, exp_int, "test that "//trim(test_descrip)//" fails" ) - end do - - call shr_sys_system( "/bin/rm -f "//trim(stream_filename), rcode ) - deallocate( streams ) - deallocate( streams2 ) - - call test_final() - -end program test_shr_streams - diff --git a/test/old_unit_testers/test_shr_sys.F90 b/test/old_unit_testers/test_shr_sys.F90 deleted file mode 100644 index 674eda1..0000000 --- a/test/old_unit_testers/test_shr_sys.F90 +++ /dev/null @@ -1,75 +0,0 @@ - program test_shr_sys -! -! Simple unit-test program for the shr_sys_mod module. -! -! Erik Kluzek -! -! $Id: test_shr_sys.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ -! - use shr_kind_mod, only: SHR_KIND_I8, SHR_KIND_R8 - use shr_sys_mod, only: shr_sys_irtc, shr_sys_system, shr_sys_flush, & - shr_sys_getenv, shr_sys_chdir, shr_sys_sleep, & - shr_sys_abort - implicit none - real(SHR_KIND_R8) sum - integer i -#if (defined AIX) - integer(kind=8):: irtc0, irtcf - integer(kind=8):: irtc -#endif - integer(SHR_KIND_I8):: sirtc0, sirtcf, rate - integer rcode - character(len=90) val - real(SHR_KIND_R8) :: sec - - print *, "Unit-tester for shr_sys_mod" - print *, "First lets test the shr_sys_irtc function" -#if (defined AIX) - irtc0 = irtc( ) -#endif - sirtc0 = shr_sys_irtc( ) - sum = 0.0_SHR_KIND_R8 - do i = 1, 10000000 - sum = sum + exp( (i*5.0_SHR_KIND_R8*3.14159265_SHR_KIND_R8) / (i + 10.0_SHR_KIND_R8) ) - end do - sirtcf = shr_sys_irtc( ) -#if (defined AIX) - print *, 'irtc call: ', irtcf - irtc0 -#endif -#if (defined AIX) - irtcf = irtc( ) -#endif - print *, 'shr_sys_irtc call: ', sirtcf - sirtc0 - print *, 'Test the getenv call' - call shr_sys_getenv( "LOGNAME", val, rcode ) - print *, "value of LOGNAME = ", val - print *, 'Test the chdir call (just do a chdir .)' - call shr_sys_system( "pwd", rcode ) - call shr_sys_chdir( ".", rcode ) - call shr_sys_system( "pwd", rcode ) - sec = 55.0_SHR_KIND_R8 - print *, 'Test the shr_sys_sleep call for a ', sec, ' second sleep' -#if (defined AIX) - irtc0 = irtc( ) -#endif - sirtc0 = shr_sys_irtc( ) - call shr_sys_sleep( sec ) - sirtcf = shr_sys_irtc( rate ) -#if (defined AIX) - irtcf = irtc( ) -#endif -#if (defined AIX) - print *, 'irtc call: ', irtcf - irtc0 - print *, 'irtc call: ', irtcf, irtc0 -#endif - print *, 'shr_sys_irtc call: ', sirtcf - sirtc0, ' seconds: ', (sirtcf - sirtc0)/rate - print *, 'shr_sys_irtc call: ', sirtcf, sirtc0 - print *, 'Test the shr_sys_flush call' - call shr_sys_flush( 6 ) - print *, 'PASS' - print *, 'Next test should abort appropriatly -- if it does so -- tests PASS' - print *, 'Finally test the shr_sys_abort call' - call shr_sys_abort - print *, 'abort call does NOT abort code -- something is wrong' - print *, 'FAIL' - end program test_shr_sys diff --git a/test/old_unit_testers/test_shr_tInterp.F90 b/test/old_unit_testers/test_shr_tInterp.F90 deleted file mode 100644 index 60a5ef7..0000000 --- a/test/old_unit_testers/test_shr_tInterp.F90 +++ /dev/null @@ -1,108 +0,0 @@ -program test_shr_tInterp -use shr_kind_mod -use test_mod -use shr_tInterp_mod -use shr_cal_mod, only : shr_cal_noleap -use shr_const_mod, only : SHR_CONST_CDAY - -implicit none - -integer :: date_lb, date_ub, date_in -integer :: sec_lb, sec_ub, sec_in -real(SHR_KIND_R8) :: f1, f2 -character(SHR_KIND_CS) :: alogo -character(SHR_KIND_CS) :: calendar_name = shr_cal_noleap -real(SHR_KIND_R8) :: expected(2), values(2) -integer :: rc -integer, parameter :: LIN_TEST = 1, LOWER_TEST = 2, UPPER_TEST = 3, & - NEAREST_TEST = 4, num_tests = 4, num_times = 47 -integer :: n, i - -call test_init( num_tests*num_times+3 ) -do n = 1, num_tests - if ( n == LIN_TEST )then - alogo = 'linear' - else if ( n == LOWER_TEST )then - alogo = 'lower' - else if ( n == UPPER_TEST )then - alogo = 'upper' - else if ( n == NEAREST_TEST )then - alogo = 'nearest' - end if - - write(*,*) "Test type: ", trim(alogo) - - date_lb = 20010101 - date_ub = 20010102 - sec_lb = 0 - sec_ub = 0 - date_in = 20010101 - sec_in = 0 - do i = 1, num_times - write(*,*) "seconds in ", sec_in - if ( n == LIN_TEST )then - f1 = sec_in / SHR_CONST_CDAY - expected = (/ 1.0_SHR_KIND_R8 - f1, f1 /) - else if ( n == LOWER_TEST )then - expected = (/ 1.0_SHR_KIND_R8, 0.0_SHR_KIND_R8 /) - else if ( n == UPPER_TEST )then - expected = (/ 0.0_SHR_KIND_R8, 1.0_SHR_KIND_R8 /) - else if ( n == NEAREST_TEST )then - if ( sec_in <= SHR_CONST_CDAY /2 )then - expected = (/ 1.0_SHR_KIND_R8, 0.0_SHR_KIND_R8 /) - else - expected = (/ 0.0_SHR_KIND_R8, 1.0_SHR_KIND_R8 /) - end if - end if - call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & - sec_in, f1, f2, calendar_name, algo=alogo ) - values(1) = f1 - values(2) = f2 - if ( alogo == "linear" )then - call test_close( values, expected, 1.e-10_SHR_KIND_R8, "Test if factors are as expected" ) - else - call test_is( values, expected, "Test if factors are as expected" ) - end if - sec_in = sec_in + 1800 - end do -end do - -! Error tests -call shr_tInterp_setAbort( flag=.false. ) - -alogo = 'linear' - -! lb and ub dates are the same -date_lb = 20010101 -date_ub = 20010101 -sec_lb = 1457 -sec_ub = 1456 -date_in = 20010101 -sec_in = 1456 -call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & - sec_in, f1, f2, calendar_name, algo=alogo, rc=rc ) -call test_is( rc, expected=1, description="Test that aborts if ub < lb date" ) - -! unrecognized alogorithm name - -alogo = 'zztop' -call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & - sec_in, f1, f2, calendar_name, algo=alogo, rc=rc ) -call test_is( rc, expected=1, description="Test that recognizes a bad alogo name" ) - -! Test that abort if input date is outside of interval of lb and ub - -alogo = 'linear' -date_lb = 20010101 -date_ub = 20010115 -sec_lb = 0 -sec_ub = 0 -date_in = 20010205 -sec_in = 1456 -call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & - sec_in, f1, f2, calendar_name, algo=alogo, rc=rc ) -call test_is( rc, expected=1, description="Test that aborts for linear if input date is outside range of lb and ub dates" ) - -call test_final( ) - -end program test_shr_tInterp From 88c88dde15910da943ad60527ca1e9b7ac2f1ac7 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 11:15:14 -0600 Subject: [PATCH 03/26] update PIO to PIO_ROOT --- .github/actions/buildshare/action.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/actions/buildshare/action.yaml b/.github/actions/buildshare/action.yaml index 913e952..7f9a465 100644 --- a/.github/actions/buildshare/action.yaml +++ b/.github/actions/buildshare/action.yaml @@ -40,7 +40,7 @@ runs: mkdir build-share pushd build-share export ESMFMKFILE=${{ inputs.esmfmkfile }} - export PIO=${{ inputs.pio_path }} + export PIO_ROOT=${{ inputs.pio_path }} cmake ${{ inputs.cmake_flags }} ${{ inputs.src_root }} make VERBOSE=1 popd From 29264f34f901ad7115e69fd4851c4bf1d7a605c3 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 13:41:08 -0600 Subject: [PATCH 04/26] update esmf find --- CMakeLists.txt | 14 +++++++++++--- src/shr_mpi_mod.F90 | 4 ++-- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index edd3ef1..b41d742 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -42,10 +42,18 @@ endif() if (NOT DEFINED MPILIB OR NOT ${MPILIB} STREQUAL "mpi-serial") find_package(MPI REQUIRED) endif() -set(CMAKE_MODULE_PATH "$ENV{NCAR_ROOT_ESMF}/cmake") -find_package(ESMF REQUIRED) + +if (DEFINED ENV{ESMFMKFILE}) + get_filename_component(ESMFLIB $ENV{ESMFMKFILE} DIRECTORY CACHE) +endif() +list(APPEND CMAKE_MODULE_PATH ${ESMFLIB}/../cmake) + +message("ESMF cmake is ${CMAKE_MODULE_PATH}") +find_package(ESMF REQUIRED) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") + + if("${COMPILER}" STREQUAL "nag") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -D__NAG__") endif() @@ -56,7 +64,7 @@ include(${GENF90_PATH}/CMake/genf90_utils.cmake) process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) file(GLOB SOURCES "src/*.c" "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") list(APPEND SOURCES "${SHAREGENF90SRC}") -add_definitions(-DCPRINTEL) +#add_definitions(-DCPRINTEL) add_library(share STATIC ${SOURCES}) target_include_directories(share PRIVATE include RandNum/include) diff --git a/src/shr_mpi_mod.F90 b/src/shr_mpi_mod.F90 index ab872a2..50bdaae 100644 --- a/src/shr_mpi_mod.F90 +++ b/src/shr_mpi_mod.F90 @@ -91,8 +91,8 @@ Module shr_mpi_mod shr_mpi_maxr0, & shr_mpi_maxr1 end interface shr_mpi_max - -#include ! mpi library include file + ! mpi library include file +#include !=============================================================================== CONTAINS From 3e4dacfe7e294a5a829961f9db5d874972f01adf Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 13:57:56 -0600 Subject: [PATCH 05/26] try again --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index b41d742..e2c9696 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -46,7 +46,7 @@ endif() if (DEFINED ENV{ESMFMKFILE}) get_filename_component(ESMFLIB $ENV{ESMFMKFILE} DIRECTORY CACHE) endif() -list(APPEND CMAKE_MODULE_PATH ${ESMFLIB}/../cmake) +list(APPEND CMAKE_MODULE_PATH ${ESMF_ROOT}/cmake) message("ESMF cmake is ${CMAKE_MODULE_PATH}") find_package(ESMF REQUIRED) From 8fe54997029c5478e46a7259ebb0824547276f04 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 14:13:29 -0600 Subject: [PATCH 06/26] try this --- CMakeLists.txt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index e2c9696..e41daf3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -43,11 +43,14 @@ if (NOT DEFINED MPILIB OR NOT ${MPILIB} STREQUAL "mpi-serial") find_package(MPI REQUIRED) endif() -if (DEFINED ENV{ESMFMKFILE}) - get_filename_component(ESMFLIB $ENV{ESMFMKFILE} DIRECTORY CACHE) +if (DEFINED ENV{ESMF_ROOT}) + list(APPEND CMAKE_MODULE_PATH $ENV{ESMF_ROOT}/cmake) +else() + if (DEFINED ENV{ESMFMKFILE}) + get_filename_component(ESMFLIB $ENV{ESMFMKFILE} DIRECTORY CACHE) + list(APPEND CMAKE_MODULE_PATH ${ESMFLIB}/../cmake) + endif() endif() -list(APPEND CMAKE_MODULE_PATH ${ESMF_ROOT}/cmake) - message("ESMF cmake is ${CMAKE_MODULE_PATH}") find_package(ESMF REQUIRED) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") From aeb6c69b491b0d23e635888abe5ebb275d128f84 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 14:44:39 -0600 Subject: [PATCH 07/26] keep trying --- .github/workflows/extbuild.yml | 2 +- src/shr_flds_mod.F90 | 16 - src/shr_map_mod.F90 | 3463 -------------------------------- src/shr_sys_mod.F90 | 2 +- src/shr_taskmap_mod.F90 | 403 ---- 5 files changed, 2 insertions(+), 3884 deletions(-) delete mode 100644 src/shr_flds_mod.F90 delete mode 100644 src/shr_map_mod.F90 delete mode 100644 src/shr_taskmap_mod.F90 diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index ecb32eb..c54b000 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -69,7 +69,7 @@ jobs: pio_path: ${GITHUB_WORKSPACE}/pio src_root: ${GITHUB_WORKSPACE} cmake_flags: " -Wno-dev -DCMAKE_BUILD_TYPE=DEBUG -DWERROR=ON -DCMAKE_Fortran_FLAGS=\"-DCPRGNU -g -Wall \ - -ffree-form -ffree-line-length-none -fallow-argument-mismatch \"" + -ffree-form -ffree-line-length-none -fallow-argument-mismatch\" -DCMAKE_MODULE_PATH=$ESMF_ROOT/cmake" - name: Test CDEPS run: | cd build-share diff --git a/src/shr_flds_mod.F90 b/src/shr_flds_mod.F90 deleted file mode 100644 index 8ddcccb..0000000 --- a/src/shr_flds_mod.F90 +++ /dev/null @@ -1,16 +0,0 @@ -module shr_flds_mod - - use shr_kind_mod , only : CX => shr_kind_CX, CXX => shr_kind_CXX - use shr_sys_mod , only : shr_sys_abort - - implicit none - public - - !---------------------------------------------------------------------------- - ! for the domain - !---------------------------------------------------------------------------- - - character(CXX) :: shr_flds_dom_coord - character(CXX) :: shr_flds_dom_other - -end module shr_flds_mod diff --git a/src/shr_map_mod.F90 b/src/shr_map_mod.F90 deleted file mode 100644 index f7ad167..0000000 --- a/src/shr_map_mod.F90 +++ /dev/null @@ -1,3463 +0,0 @@ -! !MODULE: shr_map_mod -- generic map data type and associated methods -! -! !DESCRIPTION: -! Generic map data type and associated methods -! \newline -! This module supports mapping of fields from one grid to another. -! A general datatype, shr\_map\_mapType, stores the mapping information -! set in shr\_map\_mapSet. shr\_map\_mapData then allows this mapping -! to be applied to an input array to generate the output array. -! \newline -! The mapType has several flags that give the user various options -! for setting the mapping -! type: [remap,fill] -! remap - mapping of data between different grids, primarily -! for the active grid area -! fill - mapping of data on the same grid, primarily to fill missing -! areas, copy data, or set the array to a spval. -! algo: [copy,bilinear,nn,nnoni,nnonj,spval] -! copy - copy data from one array to another using indexing -! bilinear - bilinear remapping using 4 corner points -! nn - nearest neighbor, set value to nn value -! nnoni - nearest neighbor using i, search for nearest neighbor in the -! i direction first, then j -! nnonj - nearest neighbor using j, search for nearest neighbor in the -! j direction first, then i -! spval - set values to the spval -! mask: [srcmask,dstmask,nomask,bothmask] -! srcmask - use only src points with mask = true in mapping -! dstmask - map only to dst points where mask = true -! nomask - ignore both src and dst mask in mapping -! bothmask - use both src and dst mask in mapping (srcmask and dstmask) -! vect: [scalar,vector] -! scalar - fields are scalar type (default) -! vector - fields are vector type, operates only on 2 fields to 2 fields -! NOTE: Not all combinatations are unique and not all combinations are valid -! \newline -! The above settings are put into the maptype using shr\_map\_put. Public -! parameters are available to users to set the switches. The first three -! switches must be set then the mapSet method can be called. After the -! mapSet method is called, the mapData method can be used. -! \newline -! A Note on Subroutine Arguments: -! Lat, lon, and mask arguments in these routines are 2d (nx,ny) -! Array arguments are 2d (nf,nxy), number of fields by grid point -! \newline -! General Usage: -! type(shr\_map\_mapType) :: mymap -! call shr\_map\_put(mymap,'type','remap') -! call shr\_map\_put(mymap,shr\_map\_fs\_algo,shr\_map\_fs\_bilinear) -! call shr\_map\_put(mymap,shr\_map\_fs\_mask,'bothmask') -! call shr\_map\_put(mymap,shr\_map\_fs\_vect,'scalar') -! call shr\_map\_mapSet(mymap,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,rc=rCode) -! call shr\_map\_mapData(Asrc,Adst,mymap) -! \newline -! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md,name='fillnnoni',type='fill',algo='nnoni',mask='dstmask',rc=rc) -! call shr\_map\_mapData(Asrc,Adst,mymap) -! \newline -! call shr\_map\_mapData(Ain,Aout,Xs,Ys,Ms,Xd,Yd,Md,type='remap',algo='nn',mask='dstmask',rc) -! -! !REMARKS: -! nn needs a faster algorithm -! -! !REVISION HISTORY: -! 2005-Mar-27 - T. Craig - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -module shr_map_mod - - ! !USES: - - use shr_const_mod - use shr_kind_mod - use shr_sys_mod - use shr_timer_mod - use shr_log_mod, only: s_loglev => shr_log_Level - use shr_log_mod, only: s_logunit => shr_log_Unit - - implicit none - private - - ! !PUBLIC TYPES: - - public :: shr_map_maptype ! shr_map datatype - - type shr_map_mapType ! like mct sparsematrix datatype - private - character(SHR_KIND_CS) :: name - character(SHR_KIND_CS) :: type - character(SHR_KIND_CS) :: algo - character(SHR_KIND_CS) :: mask - character(SHR_KIND_CS) :: vect - integer(SHR_KIND_IN) :: nsrc ! grid size or src - integer(SHR_KIND_IN) :: ndst ! grid size of dst - integer(SHR_KIND_IN) :: nwts ! number of total weights - real(SHR_KIND_R8) ,pointer :: xsrc(:) ! longitude, for vector, rad - real(SHR_KIND_R8) ,pointer :: ysrc(:) ! latitude , for vector, rad - real(SHR_KIND_R8) ,pointer :: xdst(:) ! longitude, for vector, rad - real(SHR_KIND_R8) ,pointer :: ydst(:) ! latitude , for vector, rad - real(SHR_KIND_R8) ,pointer :: wgts(:) ! weights - integer(SHR_KIND_IN),pointer :: isrc(:) ! input grid index - integer(SHR_KIND_IN),pointer :: idst(:) ! output grid index - character(SHR_KIND_CS) :: fill ! string to check if filled - character(SHR_KIND_CS) :: init ! initialization of dst array - end type shr_map_mapType - - ! PUBLIC MEMBER FUNCTIONS: - - public :: shr_map_checkInit ! check whether map type is set - public :: shr_map_checkFilled ! check whether map wts are set - public :: shr_map_put ! put stuff into the datatype - public :: shr_map_get ! get stuff out of the datatype - public :: shr_map_getARptr ! get ptrs out of the datatype - public :: shr_map_mapSet ! compute weights in map - public :: shr_map_mapData ! map data - public :: shr_map_listValidOpts ! list valid options - public :: shr_map_print ! print map datatype info - public :: shr_map_clean ! clean map datatype - public :: shr_map_setAbort ! set abort flag for shr_map - public :: shr_map_setDebug ! set debug level for shr_map - public :: shr_map_setDopole ! set dopole flag - - ! PUBLIC DATA MEMBERS: - - !--- Field Strings (fldStr) --- - character(SHR_KIND_CS),public,parameter :: shr_map_fs_name = 'name' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_type = 'type' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_algo = 'algo' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_mask = 'mask' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_vect = 'vect' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_nwts = 'nwts' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_nsrc = 'nsrc' - character(SHR_KIND_CS),public,parameter :: shr_map_fs_ndst = 'ndst' - - !--- "type" options --- - character(len=*),public,parameter :: shr_map_fs_fill = 'fill ' - character(len=*),public,parameter :: shr_map_fs_cfill = 'cfill ' - character(len=*),public,parameter :: shr_map_fs_remap = 'remap ' - - !--- "algorithm" options --- - character(len=*),public,parameter :: shr_map_fs_copy = 'copy ' - character(len=*),public,parameter :: shr_map_fs_bilinear = 'bilinear' - character(len=*),public,parameter :: shr_map_fs_nn = 'nn ' - character(len=*),public,parameter :: shr_map_fs_nnoni = 'nnoni ' - character(len=*),public,parameter :: shr_map_fs_nnonj = 'nnonj ' - character(len=*),public,parameter :: shr_map_fs_spval = 'spval ' - - !--- "mask" options --- - character(len=*),public,parameter :: shr_map_fs_srcmask = 'srcmask ' - character(len=*),public,parameter :: shr_map_fs_dstmask = 'dstmask ' - character(len=*),public,parameter :: shr_map_fs_nomask = 'nomask ' - character(len=*),public,parameter :: shr_map_fs_bothmask = 'bothmask' - - !--- "vect" options --- - character(len=*),public,parameter :: shr_map_fs_scalar = 'scalar ' - character(len=*),public,parameter :: shr_map_fs_vector = 'vector ' - - !--- other public parameters --- - character(SHR_KIND_CS),public,parameter :: shr_map_setTru = 'TRUE map' - character(SHR_KIND_CS),public,parameter :: shr_map_setFal = 'FALSE m ' - integer(SHR_KIND_IN) ,public,parameter :: shr_map_ispval = -99 - real(SHR_KIND_R8) ,public,parameter :: shr_map_spval = shr_const_spval - - !EOP - - !--- Must update these if anything above changes --- - integer(SHR_KIND_IN),public,parameter :: shr_map_fs_ntype = 3 - character(len=*),public,parameter :: & - shr_map_fs_types(shr_map_fs_ntype) = (/shr_map_fs_fill, & - shr_map_fs_cfill, & - shr_map_fs_remap /) - - integer(SHR_KIND_IN),public,parameter :: shr_map_fs_nalgo = 6 - character(len=*),public,parameter :: & - shr_map_fs_algos(shr_map_fs_nalgo) = (/shr_map_fs_copy, & - shr_map_fs_bilinear, & - shr_map_fs_nn, & - shr_map_fs_nnoni, & - shr_map_fs_nnonj, & - shr_map_fs_spval /) - - integer(SHR_KIND_IN),public,parameter :: shr_map_fs_nmask = 4 - character(len=*),public,parameter :: & - shr_map_fs_masks(shr_map_fs_nmask) = (/shr_map_fs_srcmask, & - shr_map_fs_dstmask, & - shr_map_fs_nomask , & - shr_map_fs_bothmask /) - - integer(SHR_KIND_IN),public,parameter :: shr_map_fs_nvect = 2 - character(len=*),public,parameter :: & - shr_map_fs_vects(shr_map_fs_nvect) = (/shr_map_fs_scalar, & - shr_map_fs_vector /) - - interface shr_map_put ; module procedure & - shr_map_putCS, & - shr_map_putR8, & - shr_map_putIN - end interface shr_map_put - - interface shr_map_get ; module procedure & - shr_map_getCS, & - shr_map_getR8, & - shr_map_getIN, & - shr_map_getAR - end interface shr_map_get - - interface shr_map_mapSet ; module procedure & - shr_map_mapSet_global, & - shr_map_mapSet_dest - end interface shr_map_mapSet - - interface shr_map_mapData ; module procedure & - shr_map_mapDatam, & - shr_map_mapDatanm - end interface shr_map_mapData - - logical,save :: doabort = .true. - logical,save :: dopole = .true. ! for bilinear - integer(SHR_KIND_IN),save :: debug = 0 - character(SHR_KIND_CS),parameter :: fillstring = 'mapisfilled' - character(SHR_KIND_CS),parameter :: inispval = 'spval' - character(SHR_KIND_CS),parameter :: initcopy = 'copy' - real(SHR_KIND_R8) ,parameter :: c0 = 0._SHR_KIND_R8 - real(SHR_KIND_R8) ,parameter :: c1 = 1._SHR_KIND_R8 - real(SHR_KIND_R8) ,parameter :: c2 = 2._SHR_KIND_R8 - real(SHR_KIND_R8) ,parameter :: eps = 1.0e-12_SHR_KIND_R8 - real(SHR_KIND_R8) ,parameter :: pi = shr_const_pi - - !=============================================================================== -contains - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkInit -- returns init state of map - ! - ! !DESCRIPTION: - ! Returns init state of map. shr\_map\_checkInit is true - ! if the type, algo, and mask are set to valid values. - ! \newline - ! test = shr\_map\_checkInit(map) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - logical function shr_map_checkInit(map) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType),intent(in) :: map - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkInit') " - - !------------------------------------------------------------------------------- - - if (shr_map_checkFldStrOpt(shr_map_fs_type,map%type) .and. & - shr_map_checkFldStrOpt(shr_map_fs_algo,map%algo) .and. & - shr_map_checkFldStrOpt(shr_map_fs_mask,map%mask)) then - shr_map_checkInit = .true. - else - shr_map_checkInit = .false. - endif - - end function shr_map_checkInit - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkFilled -- returns fill state of map - ! - ! !DESCRIPTION: - ! Returns fill state of map. shr\_map\_checkFilled is true - ! if the number of weights are greater than zero in map - ! and if the wgts, isrc, and idst arrays have been allocated to - ! that size. - ! \newline - ! test = shr\_map\_checkFilled(map) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - logical function shr_map_checkFilled(map) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType),intent(in) :: map - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: nwts - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkFilled') " - - !------------------------------------------------------------------------------- - - shr_map_checkFilled = .false. - - nwts = map%nwts - if (map%fill == fillstring .and. nwts >= 0) then - if (size(map%wgts) == nwts .and. size(map%isrc) == nwts & - .and. size(map%idst) == nwts ) then - shr_map_checkFilled = .true. - endif - endif - - end function shr_map_checkFilled - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkFldStr -- checks fldstr for validity - ! - ! !DESCRIPTION: - ! Returns true if fldstr is valid (ie. 'type','algo','mask') - ! \newline - ! test = shr\_map\_checkFldStr('type') - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - logical function shr_map_checkFldStr(fldStr) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) :: fldStr - - !XXEOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkFldStr') " - - !------------------------------------------------------------------------------- - - shr_map_checkFldStr = .false. - - if (trim(fldStr) == trim(shr_map_fs_type).or. & - trim(fldStr) == trim(shr_map_fs_name).or. & - trim(fldStr) == trim(shr_map_fs_algo).or. & - trim(fldStr) == trim(shr_map_fs_mask).or. & - trim(fldStr) == trim(shr_map_fs_vect).or. & - trim(fldStr) == trim(shr_map_fs_nsrc).or. & - trim(fldStr) == trim(shr_map_fs_ndst).or. & - trim(fldStr) == trim(shr_map_fs_nwts)) then - shr_map_checkFldStr = .true. - endif - - end function shr_map_checkFldStr - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkFldStrOpt -- checks cval for validity with fldstr - ! - ! !DESCRIPTION: - ! Returns true if cval is valid for fldstr (ie. 'type,remap','algo,bilinear', - ! 'mask,srcmask') - ! \newline - ! test = shr\_map\_checkFldStrOpt(shr_map_fs_algo,'bilinear') - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - logical function shr_map_checkFldStrOpt(fldStr,cval) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*),intent(in) :: fldStr - character(*),intent(in) :: cval - - !XXEOP - - !--- local --- - integer(SHR_KIND_IN) :: n - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkFldStrOpt') " - - !------------------------------------------------------------------------------- - - shr_map_checkFldStrOpt = .false. - - if (.not.shr_map_checkFldStr(fldStr)) return - - if (trim(fldStr) == trim(shr_map_fs_name)) then - shr_map_checkFldStrOpt = .true. - elseif (trim(fldStr) == trim(shr_map_fs_type)) then - do n = 1,shr_map_fs_ntype - if (trim(cval) == trim(shr_map_fs_types(n))) shr_map_checkFldStrOpt = .true. - enddo - elseif (trim(fldStr) == trim(shr_map_fs_algo)) then - do n = 1,shr_map_fs_nalgo - if (trim(cval) == trim(shr_map_fs_algos(n))) shr_map_checkFldStrOpt = .true. - enddo - elseif (trim(fldStr) == trim(shr_map_fs_mask)) then - do n = 1,shr_map_fs_nmask - if (trim(cval) == trim(shr_map_fs_masks(n))) shr_map_checkFldStrOpt = .true. - enddo - elseif (trim(fldStr) == trim(shr_map_fs_vect)) then - do n = 1,shr_map_fs_nvect - if (trim(cval) == trim(shr_map_fs_vects(n))) shr_map_checkFldStrOpt = .true. - enddo - endif - - end function shr_map_checkFldStrOpt - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_getCS -- get string from map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_get methods for chars - ! returns value cval for input fldstr in map - ! \newline - ! call shr\_map\_get(mymap,shr\_map\_fs\_type,cval) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_getCS(map,fldStr,cval) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(in) :: map - character(*) ,intent(in) :: fldStr - character(*) ,intent(out):: cval - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_getCS') " - - !------------------------------------------------------------------------------- - - cval = shr_map_setFal - if (.not.shr_map_checkFldStr(fldStr)) then - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - return - endif - - if (trim(fldStr) == trim(shr_map_fs_name)) then - cval = map%name - elseif (trim(fldStr) == trim(shr_map_fs_type)) then - cval = map%type - elseif (trim(fldStr) == trim(shr_map_fs_algo)) then - cval = map%algo - elseif (trim(fldStr) == trim(shr_map_fs_mask)) then - cval = map%mask - elseif (trim(fldStr) == trim(shr_map_fs_vect)) then - cval = map%vect - else - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - endif - - end subroutine shr_map_getCS - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_getIN -- get integer from map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_get methods for integers - ! returns value ival for input fldstr in map - ! \newline - ! call shr\_map\_get(mymap,shr\_map\_fs\_nwts,ival) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_getIN(map,fldStr,ival) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(in) :: map - character(*) ,intent(in) :: fldStr - integer(SHR_KIND_IN) ,intent(out):: ival - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_getIN') " - - !------------------------------------------------------------------------------- - - ival = shr_map_ispval - if (.not.shr_map_checkFldStr(fldStr)) then - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - return - endif - - if (trim(fldStr) == trim(shr_map_fs_nwts)) then - ival = map%nwts - elseif (trim(fldStr) == trim(shr_map_fs_nsrc)) then - ival = map%nsrc - elseif (trim(fldStr) == trim(shr_map_fs_ndst)) then - ival = map%ndst - else - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - endif - - end subroutine shr_map_getIN - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_getR8 -- get real from map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_get methods for reals - ! returns value rval for input fldstr in map - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_getR8(map,fldStr,rval) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(in) :: map - character(*) ,intent(in) :: fldStr - real(SHR_KIND_R8) ,intent(out):: rval - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_getR8') " - - !------------------------------------------------------------------------------- - - rval = shr_map_spval - if (.not.shr_map_checkFldStr(fldStr)) then - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - return - endif - - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - - end subroutine shr_map_getR8 - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_getAR -- get arrays from map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_get methods for arrays - ! returns value ival for input fldstr in map - ! \newline - ! call shr\_map\_get(mymap,idst,isrc,wgts) - ! - ! !REVISION HISTORY: - ! 2009-Jul-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_getAR(map,isrc,idst,wgts) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(in) :: map - integer(SHR_KIND_IN),pointer,optional :: isrc(:) - integer(SHR_KIND_IN),pointer,optional :: idst(:) - real (SHR_KIND_R8),pointer,optional :: wgts(:) - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: nwts - - !--- formats --- - character(*),parameter :: subName = "('shr_map_getAR') " - - !------------------------------------------------------------------------------- - - nwts = map%nwts - - if (present(isrc)) then - if (size(isrc) < nwts) then - call shr_sys_abort(subName//' ERROR is isrc size') - endif - isrc(1:nwts) = map%isrc(1:nwts) - endif - - if (present(idst)) then - if (size(idst) < nwts) then - call shr_sys_abort(subName//' ERROR is idst size') - endif - idst(1:nwts) = map%idst(1:nwts) - endif - - if (present(wgts)) then - if (size(wgts) < nwts) then - call shr_sys_abort(subName//' ERROR is wgts size') - endif - wgts(1:nwts) = map%wgts(1:nwts) - endif - - end subroutine shr_map_getAR - - subroutine shr_map_getARptr(map,isrc,idst,wgts) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(in) :: map - integer(SHR_KIND_IN),pointer,optional :: isrc(:) - integer(SHR_KIND_IN),pointer,optional :: idst(:) - real (SHR_KIND_R8),pointer,optional :: wgts(:) - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: nwts - - !--- formats --- - character(*),parameter :: subName = "('shr_map_getAR') " - - !------------------------------------------------------------------------------- - - nwts = map%nwts - - if (present(isrc)) then - isrc(1:nwts) => map%isrc(1:nwts) - endif - - if (present(idst)) then - idst(1:nwts) => map%idst(1:nwts) - endif - - if (present(wgts)) then - wgts(1:nwts) => map%wgts(1:nwts) - endif - - end subroutine shr_map_getARptr - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_putCS -- put char to map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_put methods for chars - ! puts value cval for input fldstr in map - ! verify is optional argument that check validity and will - ! call abort if cval is not valid option for fldstr. - ! \newline - ! call shr\_map\_put(mymap,shr\_map\_fs\_algo,shr\_map\_fs\_bilinear) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_putCS(map,fldStr,cval,verify) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(inout):: map - character(*) ,intent(in) :: fldStr - character(*) ,intent(in) :: cval - logical,optional ,intent(in) :: verify ! check if string is valid - - !EOP - - !--- local --- - logical :: lverify - - !--- formats --- - character(*),parameter :: subName = "('shr_map_putCS') " - - !------------------------------------------------------------------------------- - - lverify = .true. - if (present(verify)) lverify = verify - if (lverify .and. .not.shr_map_checkFldStrOpt(fldStr,cval)) then - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)//' '//trim(cval)) - return - endif - - if (trim(fldStr) == trim(shr_map_fs_name)) then - map%name = cval - elseif (trim(fldStr) == trim(shr_map_fs_type)) then - map%type = cval - elseif (trim(fldStr) == trim(shr_map_fs_algo)) then - map%algo = cval - elseif (trim(fldStr) == trim(shr_map_fs_mask)) then - map%mask = cval - elseif (trim(fldStr) == trim(shr_map_fs_vect)) then - map%vect = cval - else - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - endif - - end subroutine shr_map_putCS - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_putIN -- put integer to map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_put methods for integers - ! puts value ival for input fldstr in map - ! verify is optional argument that check validity and will - ! call abort if ival is not valid option for fldstr. - ! \newline - ! call shr\_map\_put(mymap,shr\_map\_fs\_nwts,-1) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_putIN(map,fldStr,ival,verify) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(inout):: map - character(*) ,intent(in) :: fldStr - integer(SHR_KIND_IN) ,intent(in) :: ival - logical,optional ,intent(in) :: verify ! check if string is valid - - !EOP - - !--- local --- - logical :: lverify - - !--- formats --- - character(*),parameter :: subName = "('shr_map_putIN') " - character(*),parameter :: F01 = "('(shr_map_putIN) ',a,i8) " - - !------------------------------------------------------------------------------- - - lverify = .true. - if (present(verify)) lverify = verify - if (lverify .and. .not.shr_map_checkFldStr(fldStr)) then - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - return - endif - - if (trim(fldStr) == trim(shr_map_fs_nwts)) then - map%nwts = ival - elseif (trim(fldStr) == trim(shr_map_fs_nsrc)) then - map%nsrc = ival - elseif (trim(fldStr) == trim(shr_map_fs_ndst)) then - map%ndst = ival - else - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - endif - - end subroutine shr_map_putIN - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_putR8 -- put real to map - ! - ! !DESCRIPTION: - ! one of the shr\_map\_put methods for reals - ! puts value rval for input fldstr in map - ! verify is optional argument that check validity and will - ! call abort if rval is not valid option for fldstr. - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_putR8(map,fldStr,rval,verify) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(inout):: map - character(*) ,intent(in) :: fldStr - real(SHR_KIND_R8) ,intent(in) :: rval - logical,optional ,intent(in) :: verify ! check if string is valid - - !EOP - - !--- local --- - logical :: lverify - - !--- formats --- - character(*),parameter :: subName = "('shr_map_putR8') " - - !------------------------------------------------------------------------------- - - lverify = .true. - if (present(verify)) lverify = verify - if (lverify .and. .not.shr_map_checkFldStr(fldStr)) then - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - return - endif - - call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) - - end subroutine shr_map_putR8 - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_print -- write map to stdout - ! - ! !DESCRIPTION: - ! Write map info to stdout - ! \newline - ! call shr\_map\_print(mymap) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_print(map) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(in) :: map - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_print') " - character(*),parameter :: F00 = "('(shr_map_print) ',a) " - character(*),parameter :: F01 = "('(shr_map_print) ',a,2l2) " - character(*),parameter :: F02 = "('(shr_map_print) ',a,i8) " - character(*),parameter :: F03 = "('(shr_map_print) ',a,3i8) " - character(*),parameter :: F04 = "('(shr_map_print) ',a,2i8) " - character(*),parameter :: F05 = "('(shr_map_print) ',a,2e20.13) " - - if (s_loglev > 0) then - write(s_logunit,*) ' ' - write(s_logunit,F01) ' name : '//trim(map%name),shr_map_checkInit(map),shr_map_checkFilled(map) - write(s_logunit,F00) ' type : '//trim(map%type) - write(s_logunit,F00) ' algo : '//trim(map%algo) - write(s_logunit,F00) ' mask : '//trim(map%mask) - write(s_logunit,F00) ' vect : '//trim(map%vect) - write(s_logunit,F04) ' gsiz : ',map%nsrc,map%ndst - write(s_logunit,F05) ' xsrc : ',minval(map%xsrc),maxval(map%xsrc) - write(s_logunit,F05) ' ysrc : ',minval(map%ysrc),maxval(map%ysrc) - write(s_logunit,F05) ' xdst : ',minval(map%xdst),maxval(map%xdst) - write(s_logunit,F05) ' ydst : ',minval(map%ydst),maxval(map%ydst) - write(s_logunit,F02) ' nwts : ',map%nwts - write(s_logunit,F03) ' wsiz : ',size(map%wgts),size(map%isrc),size(map%idst) - write(s_logunit,F00) ' init : '//trim(map%init) - - call shr_sys_flush(s_logunit) - endif - - end subroutine shr_map_print - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_listValidOpts -- list the valid switches for map - ! - ! !DESCRIPTION: - ! Lists the valid switches for map, informational only - ! \newline - ! call shr\_map\_listValidOpts() - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_listValidOpts() - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: n - - !--- formats --- - character(*),parameter :: subName = "('shr_map_listValidOpts') " - character(*),parameter :: F00 = "('(shr_map_listValidOpts) ',a) " - - !------------------------------------------------------------------------------- - - if (s_loglev > 0) then - write(s_logunit,F00) ':' - write(s_logunit,F00) ' '//trim(shr_map_fs_name)//' : any character string' - do n = 1,shr_map_fs_ntype - write(s_logunit,F00) ' '//trim(shr_map_fs_type)//' : '//trim(shr_map_fs_types(n)) - enddo - do n = 1,shr_map_fs_nalgo - write(s_logunit,F00) ' '//trim(shr_map_fs_algo)//' : '//trim(shr_map_fs_algos(n)) - enddo - do n = 1,shr_map_fs_nmask - write(s_logunit,F00) ' '//trim(shr_map_fs_mask)//' : '//trim(shr_map_fs_masks(n)) - enddo - do n = 1,shr_map_fs_nvect - write(s_logunit,F00) ' '//trim(shr_map_fs_vect)//' : '//trim(shr_map_fs_vects(n)) - enddo - call shr_sys_flush(s_logunit) - endif - - end subroutine shr_map_listValidOpts - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_clean -- cleans map - ! - ! !DESCRIPTION: - ! Cleans map by resetting switches, deallocating arrays - ! \newline - ! call shr\_map\_clean(mymap) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_clean(map) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(inout):: map - - !EOP - - !--- local --- - integer :: rc - - !--- formats --- - character(*),parameter :: subName = "('shr_map_clean') " - character(*),parameter :: F00 = "('(shr_map_clean) ',a) " - - !------------------------------------------------------------------------------- - - map%fill = ' ' - map%init = ' ' - call shr_map_put(map,shr_map_fs_name,shr_map_setFal,verify=.false.) - call shr_map_put(map,shr_map_fs_type,shr_map_setFal,verify=.false.) - call shr_map_put(map,shr_map_fs_algo,shr_map_setFal,verify=.false.) - call shr_map_put(map,shr_map_fs_mask,shr_map_setFal,verify=.false.) - call shr_map_put(map,shr_map_fs_mask,shr_map_setFal,verify=.false.) - call shr_map_put(map,shr_map_fs_nwts,shr_map_ispval) - call shr_map_put(map,shr_map_fs_nsrc,shr_map_ispval) - call shr_map_put(map,shr_map_fs_ndst,shr_map_ispval) - deallocate(map%xsrc,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' - deallocate(map%ysrc,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' - deallocate(map%xdst,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' - deallocate(map%ydst,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' - deallocate(map%wgts,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' - deallocate(map%isrc,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map isrc' - deallocate(map%idst,stat=rc) - if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map idst' - - end subroutine shr_map_clean - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_mapSet_global -- Compute mapping weights - ! - ! !DESCRIPTION: - ! Compute mapping weights based on setting in map. Fill the - ! weights in the map. Currently supported maps and action: - ! fill :copy = copy array by index, mask switch used - ! fill :spval = copy array, fill with spval, mask switch not used - ! fill :nn* = copy array, fill with nnval, mask switch not used - ! remap:copy = copy array by index, mask switch used - ! remap:spval = sets array to spval, mask switch used - ! remap:bil* = bilinear interpolation, mask switch used - ! remap:nn* = sets array to nnval, mask switch used - ! \newline - ! Requirements for input grids: - ! Xsrc,Ysrc must be regular lat/lon grid, monotonically increasing, - ! can be degrees or radians - ! Xdst,Ydst are arbitrary list of lats/lons, must be same units as src - ! Msrc,Mdst have nonzero for active grid point, zero for non-active - ! src and dst must be the grid for type = fill - ! Grids are check for validity - ! \newline - ! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md) - ! \newline - ! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md,algo='bilinear') - ! - ! !REMARKS - ! If bothmask or srcmask is used with remap and some algorithms, active - ! dst grid points can have invalid values. A report is produced after - ! weights are calculated and this information will be detailed. - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_mapSet_global(map,Xsrc,Ysrc,Msrc,Xdst_in,Ydst,Mdst,name,type,algo,mask,vect,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(inout):: map ! map - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! lon of src grid - real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! lat of src grid - integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! mask of src grid - real(SHR_KIND_R8) ,intent(in) :: Xdst_in(:,:) ! lon of dst grid - real(SHR_KIND_R8) ,intent(in) :: Ydst(:,:) ! lat of dst grid - integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! mask of dst grid - character(*) ,optional,intent(in) :: name ! name - character(*) ,optional,intent(in) :: type ! type - character(*) ,optional,intent(in) :: algo ! algo - character(*) ,optional,intent(in) :: mask ! mask - character(*) ,optional,intent(in) :: vect ! vect - integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: nis,njs,nid,njd - integer(SHR_KIND_IN) :: nwts,n,n1,ncnt,i,j,inn,jnn - integer(SHR_KIND_IN) :: lrc - real(SHR_KIND_R8) :: rmin,rmax ! min/max value - real(SHR_KIND_R8) :: cang ! circle angle, deg or rad - real(SHR_KIND_R8),allocatable :: Xdst(:,:) ! lon of dst grid, wrapped as needed - - integer(SHR_KIND_IN) :: pmax ! max num of wgts in pti... - integer(SHR_KIND_IN) :: ptot,ptot2 ! max num of wgts in lis... - integer(SHR_KIND_IN) :: pnum ! num of wgts set in pti... - integer(SHR_KIND_IN),allocatable :: pti(:) ! i index for wgts - integer(SHR_KIND_IN),allocatable :: ptj(:) ! j index for wgts - real(SHR_KIND_R8) ,allocatable :: ptw(:) ! weights for pti,ptj - - integer(SHR_KIND_IN),allocatable :: lis(:) ! tmp src/dst index - integer(SHR_KIND_IN),allocatable :: lid(:) ! tmp src/dst index - real(SHR_KIND_R8) ,allocatable :: lwt(:) ! tmp wgt array - real(SHR_KIND_R8) ,allocatable :: sum(:) ! tmp sum array - integer(SHR_KIND_IN),allocatable :: ltmp(:) ! tmp src/dst index, for resize - real(SHR_KIND_R8) ,allocatable :: lwtmp(:) ! tmp wgt array, for resize - - character(len=8) :: units ! radians or degrees - - logical :: masksrc ! local var to turn on masking using src mask - logical :: maskdst ! local var to turn on masking using dst mask - logical :: maskdstbysrc ! local var to turn on masking using src mask for - ! dst array, especially for fill - logical :: renorm ! local var to turn on renormalization - - !--- formats --- - character(*),parameter :: subName = "('shr_map_mapSet_global') " - character(*),parameter :: F00 = "('(shr_map_mapSet_global) ',a) " - character(*),parameter :: F01 = "('(shr_map_mapSet_global) ',a,l2) " - character(*),parameter :: F02 = "('(shr_map_mapSet_global) ',a,2i8) " - character(*),parameter :: F03 = "('(shr_map_mapSet_global) ',a,2e20.13) " - - !------------------------------------------------------------------------------- - - lrc = 0 - if (present(rc)) rc = lrc - - if (present(name)) call shr_map_put(map,shr_map_fs_name,name) - if (present(type)) call shr_map_put(map,shr_map_fs_type,type,verify=.true.) - if (present(algo)) call shr_map_put(map,shr_map_fs_algo,algo,verify=.true.) - if (present(mask)) call shr_map_put(map,shr_map_fs_mask,mask,verify=.true.) - if (present(vect)) call shr_map_put(map,shr_map_fs_vect,vect,verify=.true.) - map%init = inispval - - if (.NOT.shr_map_checkInit(map)) then - call shr_map_abort(subName//' ERROR map not initialized') - endif - - !--- is lat/lon degrees or radians? --- - cang = 360._SHR_KIND_R8 - units = 'degrees' - if (shr_map_checkRad(Ysrc)) then - cang=c2*pi - units = 'radians' - endif - - nis = size(Xsrc,1) - njs = size(Xsrc,2) - nid = size(Xdst_in,1) - njd = size(Xdst_in,2) - - !--- shift Xdst by 2pi to range of Xsrc as needed --- - allocate(Xdst(nid,njd)) - rmin = minval(Xsrc) - rmax = maxval(Xsrc) - do j=1,njd - do i=1,nid - Xdst(i,j) = Xdst_in(i,j) - do while ((Xdst(i,j) < rmin .and. Xdst(i,j)+cang <= rmax).or. & - (Xdst(i,j) > rmax .and. Xdst(i,j)-cang >= rmin)) - if (Xdst(i,j) < rmin) then - Xdst(i,j) = Xdst(i,j) + cang - elseif (Xdst(i,j) > rmax) then - Xdst(i,j) = Xdst(i,j) - cang - else - call shr_sys_abort(subName//' ERROR in Xdst wrap') - endif - enddo - enddo - enddo - - call shr_map_checkGrids_global(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,lrc) - - map%nwts = 0 - map%nsrc = nis*njs - map%ndst = nid*njd - - ! deallocate(map%xsrc,stat=irc) ! this used to be a safe way to delloc when necessary, - ! deallocate(map%ysrc,stat=irc) ! but do nothing when pointers were undefined or - ! deallocate(map%xdst,stat=irc) ! un-associated, in Oct 2005, undefined ptrs started - ! deallocate(map%ydst,stat=irc) ! causing seg-faults on bluesky (B. Kauffman) - allocate(map%xsrc(nis*njs)) - allocate(map%ysrc(nis*njs)) - allocate(map%xdst(nid*njd)) - allocate(map%ydst(nid*njd)) - do j=1,njs - do i=1,nis - call shr_map_2dto1d(n1,nis,njs,i,j) - map%xsrc(n1) = Xsrc(i,j)*c2*pi/cang - map%ysrc(n1) = Ysrc(i,j)*c2*pi/cang - enddo - enddo - do j=1,njd - do i=1,nid - call shr_map_2dto1d(n1,nid,njd,i,j) - map%xdst(n1) = Xdst(i,j)*c2*pi/cang - map%ydst(n1) = Ydst(i,j)*c2*pi/cang - enddo - enddo - - masksrc = .false. - maskdstbysrc = .false. - maskdst = .false. - renorm = .true. - - if (trim(map%type) /= trim(shr_map_fs_fill) .and. & - trim(map%type) /= trim(shr_map_fs_cfill)) then - if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & - trim(map%mask) == trim(shr_map_fs_srcmask)) masksrc = .true. - if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & - trim(map%mask) == trim(shr_map_fs_dstmask)) maskdst = .true. - endif - if (trim(map%algo) == trim(shr_map_fs_spval)) then - masksrc = .false. - renorm = .false. - endif - - if (debug > 1) then - if (s_loglev > 0) write(s_logunit,*) ' ' - call shr_map_print(map) - endif - - if (lrc /= 0) then - if (present(rc)) rc = lrc - return - endif - - if (trim(map%algo) == trim(shr_map_fs_bilinear)) then - if (dopole) then - pmax = nis+2 ! possible for high lat points - ptot = 4*nid*njd ! start with bilinear estimate - else - pmax = 4 ! bilinear with 4 wts/map - ptot = 4*nid*njd - endif - else - pmax = 1 ! nn with 1 wts/map - ptot = 1*nid*njd - endif - allocate(lis(ptot)) - allocate(lid(ptot)) - allocate(lwt(ptot)) - allocate(pti(pmax)) - allocate(ptj(pmax)) - allocate(ptw(pmax)) - - !--- full array copy is default --- - nwts = nid*njd - do n=1,nwts - lid(n) = n - lis(n) = mod(n-1,nis*njs)+1 - lwt(n) = c1 - enddo - - !--- index copy anytime algo = copy --- - if (trim(map%algo) == trim(shr_map_fs_copy)) then - map%init = initcopy - ! just use copy default - - !--- for fill --- - elseif (trim(map%type) == trim(shr_map_fs_fill) .or. & - trim(map%type) == trim(shr_map_fs_cfill)) then - map%init = initcopy - if (trim(map%algo) == trim(shr_map_fs_spval)) then - maskdstbysrc = .true. - elseif (trim(map%algo) == trim(shr_map_fs_nn)) then - do n=1,nwts - call shr_map_1dto2d(lis(n),nis,njs,i,j) - if (Msrc(i,j) == 0) then - call shr_map_findnn(Xsrc(i,j),Ysrc(i,j),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - endif - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then - do n=1,nwts - call shr_map_1dto2d(lis(n),nis,njs,i,j) - if (Msrc(i,j) == 0) then - call shr_map_findnnon('i',Xsrc(i,j),Ysrc(i,j),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - endif - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then - do n=1,nwts - call shr_map_1dto2d(lis(n),nis,njs,i,j) - if (Msrc(i,j) == 0) then - call shr_map_findnnon('j',Xsrc(i,j),Ysrc(i,j),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - endif - enddo - else - call shr_map_abort(subName//' ERROR: unsupported map option combo') - endif - - !--- for remap --- - elseif (trim(map%type) == trim(shr_map_fs_remap)) then - map%init = inispval - if (trim(map%algo) == trim(shr_map_fs_spval)) then - nwts = 0 - elseif (trim(map%algo) == trim(shr_map_fs_nn)) then - do n=1,nwts - call shr_map_1dto2d(lid(n),nid,njd,i,j) - call shr_map_findnn(Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then - do n=1,nwts - call shr_map_1dto2d(lid(n),nid,njd,i,j) - call shr_map_findnnon('i',Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then - do n=1,nwts - call shr_map_1dto2d(lid(n),nid,njd,i,j) - call shr_map_findnnon('j',Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - enddo - elseif (trim(map%algo) == trim(shr_map_fs_bilinear)) then - nwts = 0 - do n=1,nid*njd - call shr_map_1dto2d(n,nid,njd,i,j) - call shr_map_getWts(Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,pti,ptj,ptw,pnum,units) - if (nwts + pnum > size(lwt)) then - !--- resize lis, lid, lwt. ptot is old size, ptot2 is new size - ptot = size(lwt) - ptot2 = ptot + max(ptot/2,pnum*10) - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) 'resize wts ',ptot,ptot2 - allocate(ltmp(ptot)) - ltmp(1:nwts) = lis(1:nwts) - deallocate(lis) - allocate(lis(ptot2)) - lis(1:nwts) = ltmp(1:nwts) - ltmp(1:nwts) = lid(1:nwts) - deallocate(lid) - allocate(lid(ptot2)) - lid(1:nwts) = ltmp(1:nwts) - deallocate(ltmp) - allocate(lwtmp(ptot)) - lwtmp(1:nwts) = lwt(1:nwts) - deallocate(lwt) - allocate(lwt(ptot2)) - lwt(1:nwts) = lwtmp(1:nwts) - deallocate(lwtmp) - endif - do n1 = 1,pnum - nwts = nwts + 1 - lid(nwts) = n - call shr_map_2dto1d(lis(nwts),nis,njs,pti(n1),ptj(n1)) - lwt(nwts) = ptw(n1) - enddo - enddo - else - call shr_map_abort(subName//' ERROR: unsupported map option combo') - if (present(rc)) rc = 1 - return - endif - else - call shr_map_abort(subName//' ERROR: unsupported map option combo') - if (present(rc)) rc = 1 - return - endif - - !--- compress weights and copy to map --- - !--- remove 1:1 copies if initcopy - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'init: ',map%init - if (map%init == initcopy .and. & - trim(map%type) /= trim(shr_map_fs_cfill)) then - ncnt = 0 - do n=1,nwts - if (lid(n) == lis(n) .and. abs(lwt(n)-c1) < eps) then - ! skipit - else - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- remove dst grid points --- - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdst: ',maskdst - if (maskdst) then - ncnt = 0 - do n=1,nwts - call shr_map_1dto2d(lid(n),nid,njd,i,j) - if (Mdst(i,j) /= 0) then - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- remove dst grid points based on src mask--- - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdstbysrc: ',maskdstbysrc - if (maskdstbysrc) then - ncnt = 0 - do n=1,nwts - call shr_map_1dto2d(lid(n),nid,njd,i,j) - if (Msrc(i,j) /= 0) then - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points by src, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- remove src grid points --- - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'masksrc: ',masksrc - if (masksrc) then - ncnt = 0 - do n=1,nwts - call shr_map_1dto2d(lis(n),nis,njs,i,j) - if (Msrc(i,j) /= 0) then - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm src grid points, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- renormalize wgts to 1.0 --- - allocate(sum(nid*njd)) - !--- sum weights for dst grid points --- - sum(:) = c0 - do n=1,nwts - sum(lid(n)) = sum(lid(n)) + lwt(n) - enddo - !--- print min/max sum --- - rmin = maxval(sum) - rmax = minval(sum) - do n=1,nid*njd - if (sum(n) > eps) then - rmin = min(rmin,sum(n)) - rmax = max(rmax,sum(n)) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax - !--- renormalize so sum on destination is always 1.0 for active dst points - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'renorm: ',renorm - if (renorm) then - do n=1,nwts - if (sum(lid(n)) > eps) then - lwt(n) = lwt(n) / sum(lid(n)) - endif - enddo - !--- sum weights for dst grid points --- - sum(:) = c0 - do n=1,nwts - sum(lid(n)) = sum(lid(n)) + lwt(n) - enddo - !--- print min/max sum --- - rmin = maxval(sum) - rmax = minval(sum) - do n=1,nid*njd - if (sum(n) > eps) then - rmin = min(rmin,sum(n)) - rmax = max(rmax,sum(n)) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax - endif - - map%nwts = nwts - ! deallocate(map%idst,stat=irc) - ! deallocate(map%isrc,stat=irc) - ! deallocate(map%wgts,stat=irc) - allocate(map%idst(nwts)) - allocate(map%isrc(nwts)) - allocate(map%wgts(nwts)) - do n=1,nwts - map%idst(n) = lid(n) - map%isrc(n) = lis(n) - map%wgts(n) = lwt(n) - enddo - - deallocate(Xdst) - - deallocate(lis) - deallocate(lid) - deallocate(lwt) - deallocate(sum) - - deallocate(pti) - deallocate(ptj) - deallocate(ptw) - - map%fill = fillstring - call shr_map_checkWgts_global(Msrc,Mdst,map) - - if (present(rc)) rc = lrc - - end subroutine shr_map_mapSet_global - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_mapSet_dest -- Compute mapping weights - ! - ! !DESCRIPTION: - ! Compute mapping weights based on setting in map. Fill the - ! weights in the map. Currently supported maps and action: - ! fill :copy = copy array by index, mask switch used - ! fill :spval = copy array, fill with spval, mask switch not used - ! fill :nn* = copy array, fill with nnval, mask switch not used - ! remap:copy = copy array by index, mask switch used - ! remap:spval = sets array to spval, mask switch used - ! remap:bil* = bilinear interpolation, mask switch used - ! remap:nn* = sets array to nnval, mask switch used - ! \newline - ! Requirements for input grids: - ! Xsrc,Ysrc must be regular lat/lon grid, monotonically increasing - ! or decreasing, can be degrees or radians - ! Xdst,Ydst are arbitrary list of lats/lons, must be same units as src - ! Msrc,Mdst have nonzero for active grid point, zero for non-active - ! src and dst must be the grid for type = fill - ! Grids are check for validity - ! \newline - ! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md) - ! \newline - ! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md,algo='bilinear') - ! - ! !REMARKS - ! If bothmask or srcmask is used with remap and some algorithms, active - ! dst grid points can have invalid values. A report is produced after - ! weights are calculated and this information will be detailed. - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_mapSet_dest(map,Xsrc,Ysrc,Msrc,Xdst_in,Ydst,Mdst,ndst,Idst,name,type,algo,mask,vect,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - type(shr_map_mapType) ,intent(inout):: map ! map - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! lon of src grid - real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! lat of src grid - integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! mask of src grid - real(SHR_KIND_R8) ,intent(in) :: Xdst_in(:) ! lon of dst grid - real(SHR_KIND_R8) ,intent(in) :: Ydst(:) ! lat of dst grid - integer(SHR_KIND_IN) ,intent(in) :: Mdst(:) ! mask of dst grid - integer(SHR_KIND_IN) ,intent(in) :: ndst ! global size of dst - integer(SHR_KIND_IN) ,intent(in) :: Idst(:) ! global index of dst grid - character(*) ,optional,intent(in) :: name ! name - character(*) ,optional,intent(in) :: type ! type - character(*) ,optional,intent(in) :: algo ! algo - character(*) ,optional,intent(in) :: mask ! mask - character(*) ,optional,intent(in) :: vect ! vect - integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: nis,njs,nid,njd - integer(SHR_KIND_IN) :: nwts,n,n1,ncnt,i,j,inn,jnn - integer(SHR_KIND_IN) :: lrc - real(SHR_KIND_R8) :: rmin,rmax ! min/max value - real(SHR_KIND_R8) :: cang ! circle angle, deg or rad - real(SHR_KIND_R8),allocatable :: Xdst(:) ! lon of dst grid, wrapped as needed - - integer(SHR_KIND_IN) :: pmax ! max num of wgts in pti... - integer(SHR_KIND_IN) :: ptot,ptot2 ! max num of wgts in lis... - integer(SHR_KIND_IN) :: pnum ! num of wgts set in pti... - integer(SHR_KIND_IN),allocatable :: pti(:) ! i index for wgts - integer(SHR_KIND_IN),allocatable :: ptj(:) ! j index for wgts - real(SHR_KIND_R8) ,allocatable :: ptw(:) ! weights for pti,ptj - - integer(SHR_KIND_IN),allocatable :: lis(:) ! tmp src/dst index - integer(SHR_KIND_IN),allocatable :: lid(:) ! tmp src/dst index - real(SHR_KIND_R8) ,allocatable :: lwt(:) ! tmp wgt array - real(SHR_KIND_R8) ,allocatable :: sum(:) ! tmp sum array - integer(SHR_KIND_IN),allocatable :: ltmp(:) ! tmp src/dst index, for resize - real(SHR_KIND_R8) ,allocatable :: lwtmp(:) ! tmp wgt array, for resize - - character(len=8) :: units ! radians or degrees - - logical :: masksrc ! local var to turn on masking using src mask - logical :: maskdst ! local var to turn on masking using dst mask - logical :: maskdstbysrc ! local var to turn on masking using src mask for - ! dst array, especially for fill - logical :: renorm ! local var to turn on renormalization - - !--- formats --- - character(*),parameter :: subName = "('shr_map_mapSet_dest') " - character(*),parameter :: F00 = "('(shr_map_mapSet_dest) ',a) " - character(*),parameter :: F01 = "('(shr_map_mapSet_dest) ',a,l2) " - character(*),parameter :: F02 = "('(shr_map_mapSet_dest) ',a,2i8) " - character(*),parameter :: F03 = "('(shr_map_mapSet_dest) ',a,2e20.13) " - - !------------------------------------------------------------------------------- - - write(s_logunit,F00) 'ERROR this routine is not validated' - call shr_sys_abort(subName//' ERROR subroutine not validated') - - lrc = 0 - if (present(rc)) rc = lrc - - if (present(name)) call shr_map_put(map,shr_map_fs_name,name) - if (present(type)) call shr_map_put(map,shr_map_fs_type,type,verify=.true.) - if (present(algo)) call shr_map_put(map,shr_map_fs_algo,algo,verify=.true.) - if (present(mask)) call shr_map_put(map,shr_map_fs_mask,mask,verify=.true.) - if (present(vect)) call shr_map_put(map,shr_map_fs_vect,vect,verify=.true.) - map%init = inispval - - if (.NOT.shr_map_checkInit(map)) then - call shr_map_abort(subName//' ERROR map not initialized') - endif - - !--- is lat/lon degrees or radians? --- - cang = 360._SHR_KIND_R8 - units = 'degrees' - if (shr_map_checkRad(Ysrc)) then - cang=c2*pi - units = 'radians' - endif - - nis = size(Xsrc,1) - njs = size(Xsrc,2) - nid = size(Xdst_in,1) - njd = 1 - - !--- shift Xdst by 2pi to range of Xsrc as needed --- - allocate(Xdst(nid)) - rmin = minval(Xsrc) - rmax = maxval(Xsrc) - do i=1,nid - Xdst(i) = Xdst_in(i) - do while ((Xdst(i) < rmin .and. Xdst(i)+cang <= rmax).or. & - (Xdst(i) > rmax .and. Xdst(i)-cang >= rmin)) - if (Xdst(i) < rmin) then - Xdst(i) = Xdst(i) + cang - elseif (Xdst(i) > rmax) then - Xdst(i) = Xdst(i) - cang - else - call shr_sys_abort(subName//' ERROR in Xdst wrap') - endif - enddo - enddo - - call shr_map_checkGrids_dest(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,lrc) - - map%nwts = 0 - map%nsrc = nis*njs - map%ndst = ndst - - ! deallocate(map%xsrc,stat=irc) ! this used to be a safe way to delloc when necessary, - ! deallocate(map%ysrc,stat=irc) ! but do nothing when pointers were undefined or - ! deallocate(map%xdst,stat=irc) ! un-associated, in Oct 2005, undefined ptrs started - ! deallocate(map%ydst,stat=irc) ! causing seg-faults on bluesky (B. Kauffman) - allocate(map%xsrc(nis*njs)) - allocate(map%ysrc(nis*njs)) - allocate(map%xdst(nid*njd)) - allocate(map%ydst(nid*njd)) - do j=1,njs - do i=1,nis - call shr_map_2dto1d(n1,nis,njs,i,j) - map%xsrc(n1) = Xsrc(i,j)*c2*pi/cang - map%ysrc(n1) = Ysrc(i,j)*c2*pi/cang - enddo - enddo - do i=1,nid - map%xdst(i) = Xdst(i)*c2*pi/cang - map%ydst(i) = Ydst(i)*c2*pi/cang - enddo - - masksrc = .false. - maskdstbysrc = .false. - maskdst = .false. - renorm = .true. - - if (trim(map%type) /= trim(shr_map_fs_fill) .and. & - trim(map%type) /= trim(shr_map_fs_cfill)) then - if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & - trim(map%mask) == trim(shr_map_fs_srcmask)) masksrc = .true. - if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & - trim(map%mask) == trim(shr_map_fs_dstmask)) maskdst = .true. - endif - if (trim(map%algo) == trim(shr_map_fs_spval)) then - masksrc = .false. - renorm = .false. - endif - - if (debug > 1) then - if (s_loglev > 0) write(s_logunit,*) ' ' - call shr_map_print(map) - endif - - if (lrc /= 0) then - if (present(rc)) rc = lrc - return - endif - - if (trim(map%algo) == trim(shr_map_fs_bilinear)) then - if (dopole) then - pmax = nis+2 ! possible for high lat points - ptot = 4*nid*njd ! start with bilinear estimate - else - pmax = 4 ! bilinear with 4 wts/map - ptot = 4*nid*njd - endif - else - pmax = 1 ! nn with 1 wts/map - ptot = 1*nid*njd - endif - allocate(lis(ptot)) - allocate(lid(ptot)) - allocate(lwt(ptot)) - allocate(pti(pmax)) - allocate(ptj(pmax)) - allocate(ptw(pmax)) - - !--- full array copy is default --- - nwts = nid*njd - do n=1,nwts - lid(n) = Idst(n) - lis(n) = Idst(n) - lwt(n) = c1 - enddo - - !--- index copy anytime algo = copy --- - if (trim(map%algo) == trim(shr_map_fs_copy)) then - map%init = initcopy - ! just use copy default - - !--- for fill --- - elseif (trim(map%type) == trim(shr_map_fs_fill) .or. & - trim(map%type) == trim(shr_map_fs_cfill)) then - map%init = initcopy - if (trim(map%algo) == trim(shr_map_fs_spval)) then - maskdstbysrc = .true. - elseif (trim(map%algo) == trim(shr_map_fs_nn)) then - do n=1,nwts - if (Mdst(n) == 0) then - call shr_map_findnn(Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - endif - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then - do n=1,nwts - if (Mdst(n) == 0) then - call shr_map_findnnon('i',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - endif - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then - do n=1,nwts - if (Mdst(n) == 0) then - call shr_map_findnnon('j',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - endif - enddo - else - call shr_map_abort(subName//' ERROR: unsupported map option combo') - endif - - !--- for remap --- - elseif (trim(map%type) == trim(shr_map_fs_remap)) then - map%init = inispval - if (trim(map%algo) == trim(shr_map_fs_spval)) then - nwts = 0 - elseif (trim(map%algo) == trim(shr_map_fs_nn)) then - do n=1,nwts - call shr_map_findnn(Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then - do n=1,nwts - call shr_map_findnnon('i',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - enddo - elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then - do n=1,nwts - call shr_map_findnnon('j',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) - call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) - enddo - elseif (trim(map%algo) == trim(shr_map_fs_bilinear)) then - nwts = 0 - do n=1,nid*njd - call shr_map_getWts(Xdst(n),Ydst(n),Xsrc,Ysrc,pti,ptj,ptw,pnum,units) - if (nwts + pnum > size(lwt)) then - !--- resize lis, lid, lwt. ptot is old size, ptot2 is new size - ptot = size(lwt) - ptot2 = ptot + max(ptot/2,pnum*10) - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) 'resize wts ',ptot,ptot2 - allocate(ltmp(ptot)) - ltmp(1:nwts) = lis(1:nwts) - deallocate(lis) - allocate(lis(ptot2)) - lis(1:nwts) = ltmp(1:nwts) - ltmp(1:nwts) = lid(1:nwts) - deallocate(lid) - allocate(lid(ptot2)) - lid(1:nwts) = ltmp(1:nwts) - deallocate(ltmp) - allocate(lwtmp(ptot)) - lwtmp(1:nwts) = lwt(1:nwts) - deallocate(lwt) - allocate(lwt(ptot2)) - lwt(1:nwts) = lwtmp(1:nwts) - deallocate(lwtmp) - endif - do n1 = 1,pnum - nwts = nwts + 1 - lid(nwts) = Idst(n) - call shr_map_2dto1d(lis(nwts),nis,njs,pti(n1),ptj(n1)) - lwt(nwts) = ptw(n1) - enddo - enddo - else - call shr_map_abort(subName//' ERROR: unsupported map option combo') - if (present(rc)) rc = 1 - return - endif - else - call shr_map_abort(subName//' ERROR: unsupported map option combo') - if (present(rc)) rc = 1 - return - endif - - !--- compress weights and copy to map --- - !--- remove 1:1 copies if initcopy - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'init: ',map%init - if (map%init == initcopy .and. & - trim(map%type) /= trim(shr_map_fs_cfill)) then - ncnt = 0 - do n=1,nwts - if (lid(n) == lis(n) .and. abs(lwt(n)-c1) < eps) then - ! skipit - else - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- remove dst grid points --- - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdst: ',maskdst - if (maskdst) then - ncnt = 0 - do n=1,nwts - if (Mdst(n) /= 0) then - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- remove dst grid points based on src mask--- - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdstbysrc: ',maskdstbysrc - if (maskdstbysrc) then - ncnt = 0 - do n=1,nwts - call shr_map_1dto2d(lid(n),nis,njs,i,j) - if (Msrc(i,j) /= 0) then - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points by src, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- remove src grid points --- - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'masksrc: ',masksrc - if (masksrc) then - ncnt = 0 - do n=1,nwts - call shr_map_1dto2d(lis(n),nis,njs,i,j) - if (Msrc(i,j) /= 0) then - ncnt = ncnt+1 - lid(ncnt) = lid(n) - lis(ncnt) = lis(n) - lwt(ncnt) = lwt(n) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm src grid points, nwts old/new = ',nwts,ncnt - nwts = ncnt - endif - - !--- renormalize wgts to 1.0 --- - allocate(sum(ndst)) - !--- sum weights for dst grid points --- - sum(:) = c0 - do n=1,nwts - sum(lid(n)) = sum(lid(n)) + lwt(n) - enddo - !--- print min/max sum --- - rmin = maxval(sum) - rmax = minval(sum) - do n=1,ndst - if (sum(n) > eps) then - rmin = min(rmin,sum(n)) - rmax = max(rmax,sum(n)) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax - !--- renormalize so sum on destination is always 1.0 for active dst points - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'renorm: ',renorm - if (renorm) then - do n=1,nwts - if (sum(lid(n)) > eps) then - lwt(n) = lwt(n) / sum(lid(n)) - endif - enddo - !--- sum weights for dst grid points --- - sum(:) = c0 - do n=1,nwts - sum(lid(n)) = sum(lid(n)) + lwt(n) - enddo - !--- print min/max sum --- - rmin = maxval(sum) - rmax = minval(sum) - do n=1,nid*njd - if (sum(n) > eps) then - rmin = min(rmin,sum(n)) - rmax = max(rmax,sum(n)) - endif - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax - endif - - map%nwts = nwts - ! deallocate(map%idst,stat=irc) - ! deallocate(map%isrc,stat=irc) - ! deallocate(map%wgts,stat=irc) - allocate(map%idst(nwts)) - allocate(map%isrc(nwts)) - allocate(map%wgts(nwts)) - do n=1,nwts - map%idst(n) = lid(n) - map%isrc(n) = lis(n) - map%wgts(n) = lwt(n) - enddo - - deallocate(Xdst) - - deallocate(lis) - deallocate(lid) - deallocate(lwt) - deallocate(sum) - - deallocate(pti) - deallocate(ptj) - deallocate(ptw) - - map%fill = fillstring - !! call shr_map_checkWgts_dest(Msrc,Mdst,map) - - if (present(rc)) rc = lrc - - end subroutine shr_map_mapSet_dest - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_mapDatam -- maps arrays using input map - ! - ! !DESCRIPTION: - ! Maps arrays using preset map - ! \newline - ! call shr\_map\_mapData(Ain,Aout,mymap) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_mapDatam(arrsrc,arrdst,map) - !--- map arrsrc to arrdst, each array is dimension (fields,grid index) --- - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - real(SHR_KIND_R8) ,intent(in) :: arrsrc(:,:) ! src array(fields,grid) - real(SHR_KIND_R8) ,intent(out):: arrdst(:,:) ! dst array(fields,grid) - type(shr_map_mapType) ,intent(in) :: map ! map - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: n,n2 ! counters - integer(SHR_KIND_IN) :: indi,indo ! array indices, in/out - real(SHR_KIND_R8) :: wgt ! value of weight - integer(SHR_KIND_IN) :: nfi,nfo ! number of fields in array, in/out - integer(SHR_KIND_IN) :: nsi,nso ! size of grid in array, in/out - real(SHR_KIND_R8) :: theta ! angle difference - integer(SHR_KIND_IN),save :: t0=-1,t1,t2,t4,t5 ! timers - integer(SHR_KIND_IN),parameter :: timing=0 ! turn timers off/on (0/1) - logical,pointer :: initnew(:) ! mask for initialization - - !--- formats --- - character(*),parameter :: subName = "('shr_map_mapDatam') " - character(*),parameter :: F00 = "('(shr_map_mapDatam) ',a) " - character(*),parameter :: F01 = "('(shr_map_mapDatam) ',a,2i8) " - - !------------------------------------------------------------------------------- - - if (timing>0 .and. t0 == -1) then - call shr_timer_get(t0,subName//"everything") - call shr_timer_get(t1,subName//"initial checks") - call shr_timer_get(t2,subName//"dst to spval") - call shr_timer_get(t4,subName//"map vector") - call shr_timer_get(t5,subName//"map scalar") - end if - - if (timing>0) call shr_timer_start(t0) - if (timing>0) call shr_timer_start(t1) - - !--- get number of fields --- - nfi = size(arrsrc,1) - nfo = size(arrdst,1) - - !--- check number of fields --- - if (nfi /= nfo) then - write(s_logunit,F01) ' field numbers dont match ',nfi,nfo - call shr_map_abort(subName//' ERROR number of fields') - endif - - !--- check two fields for vector --- - if (trim(map%vect) == trim(shr_map_fs_vector).and.(nfi /= 2)) then - write(s_logunit,F01) ' vector mapping, must map only two fields',nfi,nfo - call shr_map_abort(subName//' ERROR vector mapping fields not two') - endif - - !--- check that map is set --- - if (.not.shr_map_checkFilled(map)) then - write(s_logunit,F00) ' map is not filled' - call shr_map_abort(subName//' ERROR map is not filled') - endif - - !--- get size of grid --- - nsi = size(arrsrc,2) - nso = size(arrdst,2) - - !--- check size of grid --- - if (nsi /= map%nsrc) then - write(s_logunit,F01) ' src grid size doesnt match ',nsi,map%nsrc - call shr_map_abort(subName//' ERROR src grid size') - endif - if (nso /= map%ndst) then - write(s_logunit,F01) ' dst grid size doesnt match ',nso,map%ndst - call shr_map_abort(subName//' ERROR dst grid size') - endif - - if (timing>0) call shr_timer_stop(t1) - if (timing>0) call shr_timer_start(t2) - - allocate(initnew(1:nso)) - initnew = .true. - !--- set arrdst to spval, all points, default --- - if (map%init == inispval) then - arrdst = shr_map_spval - elseif (map%init == initcopy) then - if (nsi /= nso) then - write(s_logunit,F01) ' initcopy has nsi ne nso ',nsi,nso - call shr_map_abort(subName//' ERROR initcopy size') - else - do n = 1,nsi - do n2 = 1,nfo - arrdst(n2,n) = arrsrc(n2,n) - enddo - enddo - endif - else - write(s_logunit,F00) ' map%init illegal '//trim(map%init) - call shr_map_abort(subName//' ERROR map init') - endif - - if (timing>0) call shr_timer_stop(t2) - - !--- generate output array --- - if (trim(map%vect) == trim(shr_map_fs_vector)) then - if (timing>0) call shr_timer_start(t4) - do n=1,map%nwts - indi = map%isrc(n) - indo = map%idst(n) - wgt = map%wgts(n) - theta = map%xdst(indo) - map%xsrc(indi) - if (initnew(indo)) then - initnew(indo) = .false. - arrdst(1,indo) = wgt*( arrsrc(1,indi)*cos(theta) & - +arrsrc(2,indi)*sin(theta)) - arrdst(2,indo) = wgt*(-arrsrc(1,indi)*sin(theta) & - +arrsrc(2,indi)*cos(theta)) - else - arrdst(1,indo) = arrdst(1,indo) + wgt*( arrsrc(1,indi)*cos(theta) & - +arrsrc(2,indi)*sin(theta)) - arrdst(2,indo) = arrdst(2,indo) + wgt*(-arrsrc(1,indi)*sin(theta) & - +arrsrc(2,indi)*cos(theta)) - endif - enddo - if (timing>0) call shr_timer_stop(t4) - else - if (timing>0) call shr_timer_start(t5) - do n=1,map%nwts - indi = map%isrc(n) - indo = map%idst(n) - wgt = map%wgts(n) - if (initnew(indo)) then - initnew(indo) = .false. - do n2 = 1,nfo - arrdst(n2,indo) = arrsrc(n2,indi)*wgt - enddo - else - do n2 = 1,nfo - arrdst(n2,indo) = arrdst(n2,indo) + arrsrc(n2,indi)*wgt - enddo - endif - enddo - if (timing>0) call shr_timer_stop(t5) - endif - - deallocate(initnew) - - if (timing>0) call shr_timer_stop(t0) - - end subroutine shr_map_mapDatam - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_mapDatanm -- maps arrays without map - ! - ! !DESCRIPTION: - ! Maps arrays, don't save the map - ! \newline - ! call shr\_map\_mapData(Ain,Aout,Xs,Ys,Ms,Xd,Yd,Md,name,type,algo,vect,rc) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_mapDatanm(arrsrc,arrdst,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,name,type,algo,mask,vect,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - !--- map arrsrc to arrdst, each array is dimension (fields,grid index) --- - real(SHR_KIND_R8) ,intent(in) :: arrsrc(:,:) ! src array(fields,grid) - real(SHR_KIND_R8) ,intent(out):: arrdst(:,:) ! dst array(fields,grid) - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! lon of src grid - real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! lat of src grid - integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! mask of src grid - real(SHR_KIND_R8) ,intent(in) :: Xdst(:,:) ! lon of dst grid - real(SHR_KIND_R8) ,intent(in) :: Ydst(:,:) ! lat of dst grid - integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! mask of dst grid - character(*) ,intent(in) :: name ! name - character(*) ,intent(in) :: type ! type - character(*) ,intent(in) :: algo ! algo - character(*) ,intent(in) :: mask ! mask - character(*) ,optional,intent(in) :: vect ! vect - integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code - - !EOP - - !--- local --- - type(shr_map_mapType) :: map - integer(SHR_KIND_IN) :: lrc - - !--- formats --- - character(*),parameter :: subName = "('shr_map_mapDatanm') " - character(*),parameter :: F00 = "('(shr_map_mapDatanm) ',a) " - - !------------------------------------------------------------------------------- - - lrc = 0 - - call shr_map_put(map,shr_map_fs_name,name,verify=.false.) - call shr_map_put(map,shr_map_fs_type,type,verify=.true.) - call shr_map_put(map,shr_map_fs_algo,algo,verify=.true.) - call shr_map_put(map,shr_map_fs_mask,mask,verify=.true.) - if (present(vect)) then - call shr_map_put(map,shr_map_fs_vect,vect,verify=.true.) - else - call shr_map_put(map,shr_map_fs_vect,'scalar',verify=.true.) - endif - call shr_map_mapSet(map,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,rc=lrc) - call shr_map_mapData(arrsrc,arrdst,map) - - call shr_map_clean(map) - - if (present(rc)) rc = lrc - - end subroutine shr_map_mapDatanm - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_setAbort -- local interface to abort routine - ! - ! !DESCRIPTION: - ! Set doabort flag for shr_map methods, true = call shr\_sys\_abort, - ! false = write error message and continue - ! \newline - ! call shr\_map\_abort(subName//' ERROR: illegal option') - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_setAbort(flag) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - logical,intent(in) :: flag - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_setAbort') " - character(*),parameter :: F00 = "('(shr_map_setAbort) ',a) " - - !------------------------------------------------------------------------------- - - doabort = flag - - end subroutine shr_map_setAbort - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_setDebug -- set local debug level - ! - ! !DESCRIPTION: - ! Set debug level for shr_map methods, 0 = production - ! \newline - ! call shr\_map\_setDebug(2) - ! - ! !REVISION HISTORY: - ! 2005-Apr-15 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_setDebug(iflag) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - integer,intent(in) :: iflag - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_setDebug') " - character(*),parameter :: F00 = "('(shr_map_setDebug) ',a) " - - !------------------------------------------------------------------------------- - - debug = iflag - - end subroutine shr_map_setDebug - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_map_setDopole -- set dopole flag - ! - ! !DESCRIPTION: - ! set dopole flag - ! \newline - ! call shr\_map\_setDopole(flag) - ! - ! !REVISION HISTORY: - ! 2009-Jun-22 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_setDopole(flag) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - logical, intent(in) :: flag - - !EOP - - !--- local --- - - !--- formats --- - character(*),parameter :: subName = "('shr_map_setDopole') " - character(*),parameter :: F00 = "('(shr_map_setDopole) ',a) " - - dopole = flag - - end subroutine shr_map_setDopole - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_abort -- local interface to abort routine - ! - ! !DESCRIPTION: - ! Local interface to abort routine. Depending on local flag, abort, - ! either calls shr\_sys\_abort or writes abort message and continues. - ! \newline - ! call shr\_map\_abort(subName//' ERROR: illegal option') - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_abort(string) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*),optional,intent(in) :: string - - !XXEOP - - !--- local --- - character(shr_kind_CL) :: lstring - - !--- formats --- - character(*),parameter :: subName = "('shr_map_abort') " - character(*),parameter :: F00 = "('(shr_map_abort) ',a) " - - !------------------------------------------------------------------------------- - - lstring = '' - if (present(string)) lstring = string - - if (doabort) then - call shr_sys_abort(lstring) - else - write(s_logunit,F00) trim(lstring) - endif - - end subroutine shr_map_abort - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkGrids_global -- local routine to check mapSet grids - ! - ! !DESCRIPTION: - ! Local method to check grid arguments in shr\_map\_mapSet - ! \newline - ! call shr\_map\_checkGrids_global(Xs,Ys,Ms,Xd,Yd,Md,mymap) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_checkGrids_global(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! src lat - real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! src lon - integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! src mask - real(SHR_KIND_R8) ,intent(in) :: Xdst(:,:) ! dst lat - real(SHR_KIND_R8) ,intent(in) :: Ydst(:,:) ! dst lon - integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! dst mask - type(shr_map_mapType),intent(in) :: map ! map - integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code - - !XXEOP - - !--- local --- - integer(SHR_KIND_IN) :: i,j,nis,njs,nid,njd,ncnt - logical :: error,flag - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkGrids_global') " - character(*),parameter :: F00 = "('(shr_map_checkGrids_global) ',a) " - character(*),parameter :: F01 = "('(shr_map_checkGrids_global) ',a,2i8) " - character(*),parameter :: F02 = "('(shr_map_checkGrids_global) ',a,4i8) " - character(*),parameter :: F03 = "('(shr_map_checkGrids_global) ',a,2g20.13) " - character(*),parameter :: F04 = "('(shr_map_checkGrids_global) ',a,i8,a,i8) " - character(*),parameter :: F05 = "('(shr_map_checkGrids_global) ',a,i8,2g20.13) " - character(*),parameter :: F06 = "('(shr_map_checkGrids_global) ',a,2i8,2g20.13) " - - !------------------------------------------------------------------------------- - - error = .false. - if (present(rc)) rc = 0 - - !--- get size of X arrays - nis = size(Xsrc,1) - njs = size(Xsrc,2) - nid = size(Xdst,1) - njd = size(Xdst,2) - - !--- check array size consistency for src and dst - if (size(Ysrc,1) /= nis) then - write(s_logunit,F01) 'ERROR Xsrc,Ysrc i-dim mismatch',nis,size(Ysrc,1) - error = .true. - endif - if (size(Ysrc,2) /= njs) then - write(s_logunit,F01) 'ERROR Xsrc,Ysrc j-dim mismatch',njs,size(Ysrc,2) - error = .true. - endif - if (size(Msrc,1) /= nis) then - write(s_logunit,F01) 'ERROR Xsrc,Msrc i-dim mismatch',nis,size(Msrc,1) - error = .true. - endif - if (size(Msrc,2) /= njs) then - write(s_logunit,F01) 'ERROR Xsrc,Msrc j-dim mismatch',njs,size(Msrc,2) - error = .true. - endif - if (size(Ydst,1) /= nid) then - write(s_logunit,F01) 'ERROR Xdst,Ydst i-dim mismatch',nid,size(Ydst,1) - error = .true. - endif - if (size(Ydst,2) /= njd) then - write(s_logunit,F01) 'ERROR Xdst,Ydst j-dim mismatch',njd,size(Ydst,2) - error = .true. - endif - if (size(Mdst,1) /= nid) then - write(s_logunit,F01) 'ERROR Xdst,Mdst i-dim mismatch',nid,size(Mdst,1) - error = .true. - endif - if (size(Mdst,2) /= njd) then - write(s_logunit,F01) 'ERROR Xdst,Mdst j-dim mismatch',njd,size(Mdst,2) - error = .true. - endif - - !--- fill type must have same grid size on src and dst --- - if (trim(map%type) == trim(shr_map_fs_fill) .or. & - trim(map%type) == trim(shr_map_fs_cfill)) then - if (nis*njs /= nid*njd) then - write(s_logunit,F02) 'ERROR: fill type, src/dst sizes ',nis*njs,nid*njd - error = .true. - endif - endif - - !--- write min/max or X, Y and M count --- - if (debug > 1 .and. s_loglev > 0) then - write(s_logunit,F03) ' Xsrc min/max ',minval(Xsrc),maxval(Xsrc) - write(s_logunit,F03) ' Ysrc min/max ',minval(Ysrc),maxval(Ysrc) - write(s_logunit,F03) ' Xdst min/max ',minval(Xdst),maxval(Xdst) - write(s_logunit,F03) ' Ydst min/max ',minval(Ydst),maxval(Ydst) - endif - - ncnt = 0 - do j=1,njs - do i=1,nis - if (Msrc(i,j) == 0) ncnt = ncnt + 1 - enddo - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Msrc mask T ',nis*njs-ncnt,' of ',nis*njs - - ncnt = 0 - do j=1,njd - do i=1,nid - if (Mdst(i,j) == 0) ncnt = ncnt + 1 - enddo - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Mdst mask T ',nid*njd-ncnt,' of ',nid*njd - - if (trim(map%algo) == trim(shr_map_fs_bilinear)) then - - !--- check that Xsrc is monotonically increasing for bilinear --- - flag = .false. - i = 1 - do while (i < nis .and. .not.flag) - if (((Xsrc(nis,1) > Xsrc(1,1)) .and. (Xsrc(i+1,1) <= Xsrc(i,1))) .or. & - ((Xsrc(nis,1) < Xsrc(1,1)) .and. (Xsrc(i+1,1) >= Xsrc(i,1)))) then - write(s_logunit,F05) 'ERROR Xsrc not monotonic ',i,Xsrc(i+1,1),Xsrc(i,1) - flag = .true. - error = .true. - endif - i = i+1 - enddo - - !--- check that Ysrc is monotonically increasing for bilinear --- - flag = .false. - j = 1 - do while (j < njs .and. .not.flag) - if (((Ysrc(njs,1) > Ysrc(1,1)) .and. (Ysrc(1,j+1) <= Ysrc(1,j))) .or. & - ((Ysrc(njs,1) < Ysrc(1,1)) .and. (Ysrc(1,j+1) >= Ysrc(1,j)))) then - write(s_logunit,F05) 'ERROR Ysrc not monotonic ',i,Ysrc(1,j+1),Ysrc(1,j) - flag = .true. - error = .true. - endif - j = j+1 - enddo - - !--- check that Xsrc and Ysrc are regular lat/lon grids for bilinear - flag = .false. - i = 1 - do while (i < nis .and. .not.flag) - j = 2 - do while (j < njs .and. .not.flag) - if (abs(Xsrc(i,j)-Xsrc(i,1)) > eps) then - write(s_logunit,F06) ' ERROR Xsrc not regular lat,lon ',i,j, & - Xsrc(i,j),Xsrc(1,j) - flag = .true. - error = .true. - endif - j = j+1 - enddo - i = i+1 - enddo - - flag = .false. - j = 1 - do while (j < njs .and. .not.flag) - i = 2 - do while (i < nis .and. .not.flag) - if (abs(Ysrc(i,j)-Ysrc(1,j)) > eps) then - write(s_logunit,F06) ' ERROR Ysrc not regular lat,lon ',i,j, & - Ysrc(i,j),Ysrc(1,j) - flag = .true. - error = .true. - endif - i = i+1 - enddo - j = j+1 - enddo - endif - - if (error) then - call shr_map_abort(subName//' ERROR ') - if (present(rc)) rc = 1 - endif - - end subroutine shr_map_checkGrids_global - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkGrids_dest -- local routine to check mapSet grids - ! - ! !DESCRIPTION: - ! Local method to check grid arguments in shr\_map\_mapSet - ! \newline - ! call shr\_map\_checkGrids_dest(Xs,Ys,Ms,Xd,Yd,Md,mymap) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_checkGrids_dest(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! src lat - real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! src lon - integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! src mask - real(SHR_KIND_R8) ,intent(in) :: Xdst(:) ! dst lat - real(SHR_KIND_R8) ,intent(in) :: Ydst(:) ! dst lon - integer(SHR_KIND_IN) ,intent(in) :: Mdst(:) ! dst mask - type(shr_map_mapType),intent(in) :: map ! map - integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code - - !XXEOP - - !--- local --- - integer(SHR_KIND_IN) :: i,j,nis,njs,nid,njd,ncnt - logical :: error,flag - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkGrids_dest') " - character(*),parameter :: F00 = "('(shr_map_checkGrids_dest) ',a) " - character(*),parameter :: F01 = "('(shr_map_checkGrids_dest) ',a,2i8) " - character(*),parameter :: F02 = "('(shr_map_checkGrids_dest) ',a,4i8) " - character(*),parameter :: F03 = "('(shr_map_checkGrids_dest) ',a,2g20.13) " - character(*),parameter :: F04 = "('(shr_map_checkGrids_dest) ',a,i8,a,i8) " - character(*),parameter :: F05 = "('(shr_map_checkGrids_dest) ',a,i8,2g20.13) " - character(*),parameter :: F06 = "('(shr_map_checkGrids_dest) ',a,2i8,2g20.13) " - - !------------------------------------------------------------------------------- - - error = .false. - if (present(rc)) rc = 0 - - !--- get size of X arrays - nis = size(Xsrc,1) - njs = size(Xsrc,2) - nid = size(Xdst,1) - njd = 1 - - !--- check array size consistency for src and dst - if (size(Ysrc,1) /= nis) then - write(s_logunit,F01) 'ERROR Xsrc,Ysrc i-dim mismatch',nis,size(Ysrc,1) - error = .true. - endif - if (size(Ysrc,2) /= njs) then - write(s_logunit,F01) 'ERROR Xsrc,Ysrc j-dim mismatch',njs,size(Ysrc,2) - error = .true. - endif - if (size(Msrc,1) /= nis) then - write(s_logunit,F01) 'ERROR Xsrc,Msrc i-dim mismatch',nis,size(Msrc,1) - error = .true. - endif - if (size(Msrc,2) /= njs) then - write(s_logunit,F01) 'ERROR Xsrc,Msrc j-dim mismatch',njs,size(Msrc,2) - error = .true. - endif - if (size(Ydst,1) /= nid) then - write(s_logunit,F01) 'ERROR Xdst,Ydst i-dim mismatch',nid,size(Ydst,1) - error = .true. - endif - if (size(Mdst,1) /= nid) then - write(s_logunit,F01) 'ERROR Xdst,Mdst i-dim mismatch',nid,size(Mdst,1) - error = .true. - endif - - !--- tcraig, can't check this with dest mapset --- - ! !--- fill type must have same grid size on src and dst --- - ! if (trim(map%type) == trim(shr_map_fs_fill) .or. & - ! trim(map%type) == trim(shr_map_fs_cfill)) then - ! if (nis*njs /= nid*njd) then - ! write(s_logunit,F02) 'ERROR: fill type, src/dst sizes ',nis*njs,nid*njd - ! error = .true. - ! endif - ! endif - - !--- write min/max or X, Y and M count --- - if (debug > 1 .and. s_loglev > 0) then - write(s_logunit,F03) ' Xsrc min/max ',minval(Xsrc),maxval(Xsrc) - write(s_logunit,F03) ' Ysrc min/max ',minval(Ysrc),maxval(Ysrc) - write(s_logunit,F03) ' Xdst min/max ',minval(Xdst),maxval(Xdst) - write(s_logunit,F03) ' Ydst min/max ',minval(Ydst),maxval(Ydst) - endif - - ncnt = 0 - do j=1,njs - do i=1,nis - if (Msrc(i,j) == 0) ncnt = ncnt + 1 - enddo - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Msrc mask T ',nis*njs-ncnt,' of ',nis*njs - - ncnt = 0 - do i=1,nid - if (Mdst(i) == 0) ncnt = ncnt + 1 - enddo - if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Mdst mask T ',nid*njd-ncnt,' of ',nid*njd - - if (trim(map%algo) == trim(shr_map_fs_bilinear)) then - - !--- check that Xsrc is monotonically increasing for bilinear --- - flag = .false. - i = 1 - do while (i < nis .and. .not.flag) - if (Xsrc(i+1,1) <= Xsrc(i,1)) then - write(s_logunit,F05) 'ERROR Xsrc not increasing ',i,Xsrc(i+1,1),Xsrc(i,1) - flag = .true. - error = .true. - endif - i = i+1 - enddo - - !--- check that Ysrc is monotonically increasing for bilinear --- - flag = .false. - j = 1 - do while (j < njs .and. .not.flag) - if (Ysrc(1,j+1) <= Ysrc(1,j)) then - write(s_logunit,F05) 'ERROR Ysrc not increasing ',i,Ysrc(1,j+1),Ysrc(1,j) - flag = .true. - error = .true. - endif - j = j+1 - enddo - - !--- check that Xsrc and Ysrc are regular lat/lon grids for bilinear - flag = .false. - i = 1 - do while (i < nis .and. .not.flag) - j = 2 - do while (j < njs .and. .not.flag) - if (abs(Xsrc(i,j)-Xsrc(i,1)) > eps) then - write(s_logunit,F06) ' ERROR Xsrc not regular lat,lon ',i,j, & - Xsrc(i,j),Xsrc(1,j) - flag = .true. - error = .true. - endif - j = j+1 - enddo - i = i+1 - enddo - - flag = .false. - j = 1 - do while (j < njs .and. .not.flag) - i = 2 - do while (i < nis .and. .not.flag) - if (abs(Ysrc(i,j)-Ysrc(1,j)) > eps) then - write(s_logunit,F06) ' ERROR Ysrc not regular lat,lon ',i,j, & - Ysrc(i,j),Ysrc(1,j) - flag = .true. - error = .true. - endif - i = i+1 - enddo - j = j+1 - enddo - endif - - if (error) then - call shr_map_abort(subName//' ERROR ') - if (present(rc)) rc = 1 - endif - - end subroutine shr_map_checkGrids_dest - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_checkWgts_global -- checks weights - ! - ! !DESCRIPTION: - ! Checks weights in map for validity - ! \newline - ! call shr\_map\_checkWgts_global(Ms,Md,mymap) - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_checkWgts_global(Msrc,Mdst,map) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! src mask - integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! dst mask - type(shr_map_mapType),intent(in) :: map ! map - - !XXEOP - - !--- local --- - integer(SHR_KIND_IN) :: i,j,nis,njs,nid,njd,n - integer(SHR_KIND_IN) :: ic1,ic2,ic3,ic4,ic5 ! counters - logical :: error - real(SHR_KIND_R8),allocatable :: Csrc(:,:) - real(SHR_KIND_R8),allocatable :: Cdst(:,:) - - !--- formats --- - character(*),parameter :: subName = "('shr_map_checkWgts_global') " - character(*),parameter :: F00 = "('(shr_map_checkWgts_global) ',a) " - character(*),parameter :: F01 = "('(shr_map_checkWgts_global) ',a,i8) " - character(*),parameter :: F02 = "('(shr_map_checkWgts_global) ',a,3i8) " - character(*),parameter :: F03 = "('(shr_map_checkWgts_global) ',a,i8,a) " - - !------------------------------------------------------------------------------- - - error = .false. - - if (debug > 0) call shr_map_print(map) - - if (map%nwts < 1) then - if (s_loglev > 0) write(s_logunit,F00) 'WARNING map size is zero' - endif - - if (size(map%wgts) /= map%nwts .or. & - size(map%isrc) /= map%nwts .or. & - size(map%idst) /= map%nwts) then - call shr_map_abort(subName//'ERROR sizes inconsistent') - endif - - !--- get size of X arrays - nis = size(Msrc,1) - njs = size(Msrc,2) - nid = size(Mdst,1) - njd = size(Mdst,2) - - allocate(Csrc(nis,njs)) - allocate(Cdst(nid,njd)) - - Csrc = c0 - Cdst = c0 - - do n = 1,map%nwts - call shr_map_1dto2d(map%isrc(n),nis,njs,i,j) - Csrc(i,j) = c1 - call shr_map_1dto2d(map%idst(n),nid,njd,i,j) - Cdst(i,j) = Cdst(i,j) + map%wgts(n) - enddo - - ic1 = 0 - ic2 = 0 - ic3 = 0 - ic4 = 0 - ic5 = 0 - do j=1,njs - do i=1,nis - if (Msrc(i,j) /= 0) then ! live src pt - if (abs(Csrc(i,j)-c1) < eps) then - ic1 = ic1 + 1 ! in use - else - ic2 = ic2 + 1 ! not used - endif - else ! dead src pt - if (abs(Csrc(i,j)-c1) < eps) then - ic3 = ic3 + 1 ! in use - else - ic5 = ic5 + 1 ! not used - endif - endif - enddo - enddo - ! if (ic3 > 0) error = .true. - if (debug > 0 .and. s_loglev > 0) then - write(s_logunit,F01) ' total number of SRC points : ',nis*njs - write(s_logunit,F01) ' wgts from SRC TRUE points; used : ',ic1 - write(s_logunit,F01) ' wgts from SRC TRUE points; not used : ',ic2 - write(s_logunit,F01) ' wgts from SRC FALSE points; used : ',ic3 - write(s_logunit,F01) ' wgts from SRC FALSE points; not used : ',ic5 - endif - - ic1 = 0 - ic2 = 0 - ic3 = 0 - ic4 = 0 - ic5 = 0 - do j=1,njd - do i=1,nid - if (Mdst(i,j) /= 0) then ! wgts should sum to one - if (abs(Cdst(i,j)-c1) < eps) then - ic1 = ic1 + 1 ! wgts sum to one - else - ic2 = ic2 + 1 ! invalid wgts - endif - else ! wgts should sum to one or zero - if (abs(Cdst(i,j)-c1) < eps) then - ic3 = ic3 + 1 ! wgts sum to one - elseif (abs(Cdst(i,j)) < eps) then - ic4 = ic4 + 1 ! wgts sum to zero - else - ic5 = ic5 + 1 ! invalid wgts - endif - endif - enddo - enddo - ! if (ic2 > 0) error = .true. - ! if (ic5 > 0) error = .true. - if (debug > 0 .and. s_loglev > 0) then - write(s_logunit,F01) ' total number of DST points : ',nid*njd - write(s_logunit,F01) ' sum wgts for DST TRUE points; one : ',ic1 - if (ic2 > 0) then - write(s_logunit,F03) ' sum wgts for DST TRUE points; not : ',ic2,' **-WARNING-**' - else - write(s_logunit,F01) ' sum wgts for DST TRUE points; not : ',ic2 - endif - write(s_logunit,F01) ' sum wgts for DST FALSE points; one : ',ic3 - write(s_logunit,F01) ' sum wgts for DST FALSE points; zero : ',ic4 - write(s_logunit,F01) ' sum wgts for DST FALSE points; not : ',ic5 - endif - - deallocate(Csrc) - deallocate(Cdst) - - if (error) call shr_map_abort(subName//' ERROR invalid weights') - - end subroutine shr_map_checkWgts_global - - !=============================================================================== - !XXBOP =========================================================================== - ! - ! !IROUTINE: shr_map_getWts -- local code that sets weights for a point - ! - ! !DESCRIPTION: - ! Local code that sets weights for a point. Executes searches - ! and computes weights. For bilinear remap for example. - ! - ! !REMARKS: - ! Assumes Xsrc,Ysrc are regular lat/lon grids, monotonicallly increasing - ! on constant latitude and longitude lines. - ! Assumes Xdst,Ydst,Xsrc,Ysrc are all either radians or degrees - ! - ! !REVISION HISTORY: - ! 2005-Mar-27 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_map_getWts(Xdst,Ydst,Xsrc,Ysrc,pti,ptj,ptw,pnum,units) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - !XXEOP - - real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) - integer(SHR_KIND_IN),intent(out):: pti(:),ptj(:) - real(SHR_KIND_R8) ,intent(out):: ptw(:) - integer(SHR_KIND_IN),intent(out):: pnum - character(len=*),optional,intent(in) :: units - - !--- local --- - integer(SHR_KIND_IN) :: isize,jsize ! array sizes - integer(SHR_KIND_IN) :: n ! do loop counter - integer(SHR_KIND_IN) :: il,ir ! index of i left/mid/right - integer(SHR_KIND_IN) :: jl,ju ! index of j lower/mid/upper - integer(SHR_KIND_IN) :: pmax ! size of pti,ptj,ptw - real(SHR_KIND_R8) :: xsl,xsr ! value of Xsrc, left/right - real(SHR_KIND_R8) :: ysl,ysu ! value of Ysrc, left/right - real(SHR_KIND_R8) :: xd,yd ! value of Xdst,Ydst - real(SHR_KIND_R8) :: dx,dy,dx1,dy1 ! some d_lengths for weights calc - real(SHR_KIND_R8) :: csize ! circle angle/radians - real(SHR_KIND_R8) :: cpole ! the r8 lat value of the pole - integer(SHR_KIND_IN) :: pole ! 0=no, 1=north, 2=south - - !--- formats --- - character(*),parameter :: subName = "('shr_map_getWts') " - character(*),parameter :: F00 = "('(shr_map_getWts) ',a) " - character(*),parameter :: F02 = "('(shr_map_getWts) ',a,4g20.13) " - character(*),parameter :: F03 = "('(shr_map_getWts) ',a,2g20.13) " - character(*),parameter :: F04 = "('(shr_map_getWts) ',a,4i8) " - character(*),parameter :: F05 = "('(shr_map_getWts) ',a,3g20.13) " - - !------------------------------------------------------------------------------- - - pmax = size(pti,1) - csize = 360._SHR_KIND_R8 - !--- is lat/lon degrees or radians? needed for X wraparound --- - if (present(units)) then - if (trim(units) == 'radians') then - csize = c2*pi - elseif (index(units,'degrees').eq.0) then - call shr_sys_abort(subName//' ERROR in optional units = '//trim(units)) - endif - else - if (shr_map_checkRad(Ysrc)) csize = c2*pi - endif - - isize = size(Xsrc,1) - jsize = size(Xsrc,2) - pti = 0 - ptj = 0 - ptw = c0 - - cpole = csize/(c2*c2) - - xd = Xdst - yd = Ydst - - if (yd > cpole + 1.0e-3 .or. & - yd < -cpole - 1.0e-3) then - write(s_logunit,*) trim(subname),' ERROR: yd outside bounds ',yd - write(s_logunit,*) trim(subname),' cpole = ', cpole - call shr_map_abort(subName//' ERROR yd outside 90 degree bounds') - endif - if (yd > cpole) yd = cpole - if (yd < -cpole) yd = -cpole - - call shr_map_find4corners(Xdst,yd,Xsrc,Ysrc,il,ir,jl,ju) - - !--- bilinear --- - pnum = 4 - pole = 0 - xsl = Xsrc(il,1) - xsr = Xsrc(ir,1) - ysl = Ysrc(1,jl) - ysu = Ysrc(1,ju) - - if (Xdst < Xsrc(1,1) .or. Xdst > Xsrc(isize,1)) then - xsl = mod(Xsrc(il,1),csize) - xsr = mod(Xsrc(ir,1),csize) - xd = mod(Xdst ,csize) - if (xsl > xd) xsl = xsl - csize - if (xsr < xd) xsr = xsr + csize - endif - - if (yd > Ysrc(1,jsize)) then - if (dopole) then - pnum = isize+2 - pole = 1 - endif - ysu = cpole - elseif (yd < Ysrc(1,1)) then - if (dopole) then - pnum = isize+2 - pole = 2 - endif - ysl = -cpole - endif - - !--- compute dx1,dy1; distance from src(1) to dst - dx = (xsr-xsl) - dy = (ysu-ysl) - dx1 = ( xd-xsl) - dy1 = ( yd-Ysl) - - if (dx1 > dx .and. dx1-dx < 1.0e-7 ) dx1 = dx - if (dy1 > dy .and. dy1-dy < 1.0e-7 ) dy1 = dy - - if (dx <= c0 .or. dy <= c0 .or. dx1 > dx .or. dy1 > dy) then - write(s_logunit,*) ' ' - write(s_logunit,F02) 'ERROR in dx,dy: ',dx1,dx,dy1,dy - write(s_logunit,F03) ' dst: ',Xdst,Ydst - write(s_logunit,F04) ' ind: ',il,ir,jl,ju - write(s_logunit,F02) ' dis: ',dx1,dx,dy1,dy - write(s_logunit,F05) ' x3 : ',xsl,xd,xsr - write(s_logunit,F05) ' y3 : ',ysl,yd,ysu - write(s_logunit,*) ' ' - call shr_map_abort(subName//' ERROR in dx,dy calc') - stop - return - endif - - dx1 = dx1 / dx - dy1 = dy1 / dy - - if (pnum > pmax) then - call shr_sys_abort(subName//' ERROR pti not big enough') - endif - - if (pole == 0) then ! bilinear - - pti(1) = il - pti(2) = ir - pti(3) = il - pti(4) = ir - - ptj(1) = jl - ptj(2) = jl - ptj(3) = ju - ptj(4) = ju - - ptw(1) = (c1-dx1)*(c1-dy1) - ptw(2) = ( dx1)*(c1-dy1) - ptw(3) = (c1-dx1)*( dy1) - ptw(4) = ( dx1)*( dy1) - - elseif (pole == 1) then ! north pole - - pti(1) = il - pti(2) = ir - - ptj(1) = jl - ptj(2) = jl - - ptw(1) = (c1-dx1)*(c1-dy1) - ptw(2) = ( dx1)*(c1-dy1) - - do n=1,isize - pti(2+n) = n - ptj(2+n) = ju - ptw(2+n) = (dy1)/real(isize,SHR_KIND_R8) - enddo - - elseif (pole == 2) then ! south pole - - pti(1) = il - pti(2) = ir - - ptj(1) = ju - ptj(2) = ju - - ptw(1) = (c1-dx1)*( dy1) - ptw(2) = ( dx1)*( dy1) - - do n=1,isize - pti(2+n) = n - ptj(2+n) = jl - ptw(2+n) = (c1-dy1)/real(isize,SHR_KIND_R8) - enddo - - else - - write(s_logunit,F00) ' ERROR illegal pnum situation ' - call shr_map_abort(subName//' ERROR illegal pnum situation') - - endif - - end subroutine shr_map_getWts - - !=============================================================================== - - subroutine shr_map_find4corners(Xdst,Ydst,Xsrc,Ysrc,il,ir,jl,ju) - - ! finds 4 corner points surrounding dst in src - ! returns left, right, lower, and upper i and j index - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) - integer(SHR_KIND_IN),intent(out):: il,ir,jl,ju - - !--- local --- - integer(SHR_KIND_IN) :: isize,jsize - integer(SHR_KIND_IN) :: im,jm - - !--- formats --- - character(*),parameter :: subName = "('shr_map_find4corners') " - character(*),parameter :: F00 = "('(shr_map_find4corners) ',a,2i8) " - - !------------------------------------------------------------------------------- - - isize = size(Xsrc,1) - jsize = size(Xsrc,2) - - if (Xsrc(isize,1) > Xsrc(1,1)) then - ! increasing Xsrc - if (Xdst < Xsrc(1,1) .or. Xdst > Xsrc(isize,1)) then - il = isize - ir = 1 - else - !--- find i index where Xsrc(i) <= Xdst < Xsrc(i+1) --- - il = 1 - ir = isize - do while (ir-il > 1) - im = (ir+il)/2 - if (Xdst >= Xsrc(im,1)) then - il = im - else - ir = im - endif - enddo - endif - else - ! decreasing Xsrc - if (Xdst > Xsrc(1,1) .or. Xdst < Xsrc(isize,1)) then - il = 1 - ir = isize - else - !--- find i index where Xsrc(i) > Xdst >= Xsrc(i+1) --- - il = isize - ir = 1 - do while (il-ir > 1) - im = (ir+il)/2 - if (Xdst >= Xsrc(im,1)) then - il = im - else - ir = im - endif - enddo - endif - endif - - if (Ysrc(1,jsize) > Ysrc(1,1)) then - ! increasing Ysrc - if (Ydst > Ysrc(1,jsize)) then - jl = jsize - ju = jsize - elseif (Ydst < Ysrc(1,1)) then - jl = 1 - ju = 1 - else - !--- find j index where Ysrc(j) <= Ydst < Ysrc(j+1) --- - jl = 1 - ju = jsize - do while (ju-jl > 1) - jm = (ju+jl)/2 - if (Ydst >= Ysrc(1,jm)) then - jl = jm - else - ju = jm - endif - enddo - endif - else - ! decreasing Ysrc - if (Ydst < Ysrc(1,jsize)) then - jl = jsize - ju = jsize - elseif (Ydst > Ysrc(1,1)) then - jl = 1 - ju = 1 - else - !--- find j index where Ysrc(j) <= Ydst < Ysrc(j+1) --- - jl = jsize - ju = 1 - do while (jl-ju > 1) - jm = (ju+jl)/2 - if (Ydst >= Ysrc(1,jm)) then - jl = jm - else - ju = jm - endif - enddo - endif - endif - - end subroutine shr_map_find4corners - - !=============================================================================== - - subroutine shr_map_findnn(Xdst,Ydst,Xsrc,Ysrc,Msrc,inn,jnn) - - ! finds point in src nearest to dst, returns inn,jnn src index - ! searches using Msrc active points only - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) - integer(SHR_KIND_IN),intent(in) :: Msrc(:,:) - integer(SHR_KIND_IN),intent(out):: inn,jnn - - !--- local --- - integer(SHR_KIND_IN) :: isize,jsize - integer(SHR_KIND_IN) :: i,j - real(SHR_KIND_R8) :: dnn,dist - - !--- formats --- - character(*),parameter :: subName = "('shr_map_findnn') " - character(*),parameter :: F00 = "('(shr_map_findnn) ',a,2i8) " - - !------------------------------------------------------------------------------- - - isize = size(Xsrc,1) - jsize = size(Xsrc,2) - - inn = -1 - jnn = -1 - dnn = -1._SHR_KIND_R8 - do j=1,jsize - do i=1,isize - if (Msrc(i,j) /= 0) then - dist = shr_map_finddist(Xdst,Ydst,Xsrc(i,j),Ysrc(i,j)) - if (dist < dnn .or. inn < 0) then - dnn = dist - inn = i - jnn = j - endif - endif - enddo - enddo - - end subroutine shr_map_findnn - - !=============================================================================== - - subroutine shr_map_findnnon(dir,Xdst,Ydst,Xsrc,Ysrc,Msrc,inn,jnn) - - ! finds point in src nearest to dst searching i dir first - ! returns inn,jnn src index - ! searches using Msrc active points only - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: dir - real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst - real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) - integer(SHR_KIND_IN),intent(in) :: Msrc(:,:) - integer(SHR_KIND_IN),intent(out):: inn,jnn - - !--- local --- - integer(SHR_KIND_IN) :: isize,jsize - integer(SHR_KIND_IN) :: il,ir,jl,ju - integer(SHR_KIND_IN) :: n,i,j - integer(SHR_KIND_IN) :: is,js - integer(SHR_KIND_IN) :: i2,j2 - real(SHR_KIND_R8) :: dnn,dist,ds - - !--- formats --- - character(*),parameter :: subName = "('shr_map_findnnon') " - character(*),parameter :: F00 = "('(shr_map_findnnon) ',a,2i8) " - - !------------------------------------------------------------------------------- - - isize = size(Xsrc,1) - jsize = size(Xsrc,2) - - !--- find 4 corner points - call shr_map_find4corners(Xdst,Ydst,Xsrc,Ysrc,il,ir,jl,ju) - - !--- find closest of 4 corner points to dst, set that to is,js - is = il - js = jl - ds = shr_map_finddist(Xdst,Ydst,Xsrc(il,jl),Ysrc(il,jl)) - dist = shr_map_finddist(Xdst,Ydst,Xsrc(ir,jl),Ysrc(ir,jl)) - if (dist < ds) then - is = ir - js = jl - ds = dist - endif - dist = shr_map_finddist(Xdst,Ydst,Xsrc(il,ju),Ysrc(il,ju)) - if (dist < ds) then - is = il - js = ju - ds = dist - endif - dist = shr_map_finddist(Xdst,Ydst,Xsrc(ir,ju),Ysrc(ir,ju)) - if (dist < ds) then - is = ir - js = ju - ds = dist - endif - - inn = -1 - jnn = -1 - dnn = -1._SHR_KIND_R8 - i2 = 0 - j2 = 0 - - if (trim(dir) == 'i') then - !--- search biased over i --- - do while (inn < 0 .and. j2 < jsize) - do n=1,2 - if (n == 1) j = min(js + j2,jsize) - if (n == 2) j = max(js - j2,1) - do i=1,isize - if (Msrc(i,j) /= 0) then - dist = shr_map_finddist(Xdst,Ydst,Xsrc(i,j),Ysrc(i,j)) - if (dist < dnn .or. inn < 0) then - dnn = dist - inn = i - jnn = j - endif - endif - enddo - enddo - j2 = j2 + 1 - enddo - elseif (trim(dir) == 'j') then - !--- search biased over j --- - do while (inn < 0 .and. i2 < isize) - do n=1,2 - if (n == 1) i = min(is + i2,isize) - if (n == 2) i = max(is - i2,1) - do j=1,jsize - if (Msrc(i,j) /= 0) then - dist = shr_map_finddist(Xdst,Ydst,Xsrc(i,j),Ysrc(i,j)) - if (dist < dnn .or. inn < 0) then - dnn = dist - inn = i - jnn = j - endif - endif - enddo - enddo - i2 = i2 + 1 - enddo - else - call shr_map_abort(subName//' ERROR illegal dir '//trim(dir)) - endif - - end subroutine shr_map_findnnon - - !=============================================================================== - - real(SHR_KIND_R8) function shr_map_finddist(Xdst,Ydst,Xsrc,Ysrc) - - ! x,y distance computation - - implicit none - real(SHR_KIND_R8),intent(in) :: Xdst,Ydst,Xsrc,Ysrc - character(*),parameter :: subName = "('shr_map_finddist') " - - !------------------------------------------------------------------------------- - - shr_map_finddist = sqrt((Ydst-Ysrc)**2 + (Xdst-Xsrc)**2) - - end function shr_map_finddist - - !=============================================================================== - - logical function shr_map_checkRad(Grid) - - ! check if grid is rad or degree - - implicit none - real(SHR_KIND_R8),intent(in) :: Grid(:,:) - character(*),parameter :: subName = "('shr_map_checkRad') " - real(SHR_KIND_R8) :: rmin,rmax - - !------------------------------------------------------------------------------- - - shr_map_checkRad = .false. - rmin = minval(Grid) - rmax = maxval(Grid) - if (rmax.ne.rmin) then - shr_map_checkRad = ((rmax - rmin) < 1.01_SHR_KIND_R8*c2*pi) - else - shr_map_checkRad = .true. - end if - - end function shr_map_checkRad - - !=============================================================================== - - subroutine shr_map_1dto2d(gid,ni,nj,i,j) - - ! convert from a 1d index system to a 2d index system - ! gid is 1d index; ni,nj are 2d grid size; i,j are local 2d index - - implicit none - integer(SHR_KIND_IN),intent(in) :: gid,ni,nj - integer(SHR_KIND_IN),intent(out):: i,j - character(*),parameter :: subName = "('shr_map_1dto2d') " - character(*),parameter :: F01 = "('(shr_map_1dto2d) ',a,3i8)" - - !------------------------------------------------------------------------------- - - if (gid < 1 .or. gid > ni*nj) then - write(s_logunit,F01) 'ERROR: illegal gid ',gid,ni,nj - call shr_map_abort(subName//' ERROR') - endif - j = (gid-1)/ni+1 - i = mod(gid-1,ni)+1 - - end subroutine shr_map_1dto2d - - !=============================================================================== - - subroutine shr_map_2dto1d(gid,ni,nj,i,j) - - ! convert from a 2d index system to a 1d index system - ! gid is 1d index; ni,nj are 2d grid size; i,j are local 2d index - - implicit none - integer(SHR_KIND_IN),intent(in) :: ni,nj,i,j - integer(SHR_KIND_IN),intent(out):: gid - character(*),parameter :: subName = "('shr_map_2dto1d') " - character(*),parameter :: F01 = "('(shr_map_2dto1d) ',a,4i8)" - - !------------------------------------------------------------------------------- - - if (i < 1 .or. i > ni .or. j < 1 .or. j > nj) then - write(s_logunit,F01) 'ERROR: illegal i,j ',i,ni,j,nj - call shr_map_abort(subName//' ERROR') - endif - gid = (j-1)*ni + i - - end subroutine shr_map_2dto1d - - !=============================================================================== - !=============================================================================== -end module shr_map_mod diff --git a/src/shr_sys_mod.F90 b/src/shr_sys_mod.F90 index b89df74..bf463d5 100644 --- a/src/shr_sys_mod.F90 +++ b/src/shr_sys_mod.F90 @@ -123,7 +123,7 @@ SUBROUTINE shr_sys_chdir(path, rcode) !------------------------------------------------------------------------------- ! PURPOSE: an architecture independent system call !------------------------------------------------------------------------------- - + rcode = 0 lenpath=len_trim(path) #if (defined AIX) diff --git a/src/shr_taskmap_mod.F90 b/src/shr_taskmap_mod.F90 deleted file mode 100644 index 02151a4..0000000 --- a/src/shr_taskmap_mod.F90 +++ /dev/null @@ -1,403 +0,0 @@ -module shr_taskmap_mod -!----------------------------------------------------------------------- -! -! Purpose: -! Output mapping of MPI tasks to nodes for a specified -! communicator -! -! Methods: -! Use mpi_get_processor_name to identify the node that an MPI -! task for a given communicator is assigned to. Gather these -! data to task 0 and then write out the list of MPI -! tasks associated with each node using the designated unit -! number -! -! Author: P. Worley -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!- use statements ------------------------------------------------------ -!----------------------------------------------------------------------- - use shr_sys_mod, only: shr_sys_abort - -!----------------------------------------------------------------------- -!- module boilerplate -------------------------------------------------- -!----------------------------------------------------------------------- - implicit none - include 'mpif.h' - private - save ! Make the default access private - -!----------------------------------------------------------------------- -! Public interfaces ---------------------------------------------------- -!----------------------------------------------------------------------- - public :: & - shr_taskmap_write ! write out list of nodes - ! with list of assigned MPI tasks - ! for a given communicator - - CONTAINS - -! -!======================================================================== -! - subroutine shr_taskmap_write (unit_num, comm_id, comm_name, & - verbose, no_output, & - save_nnodes, save_task_node_map) - -!----------------------------------------------------------------------- -! Purpose: Write out list of nodes used by processes in a given -! communicator. For each node output the list of MPI tasks -! assigned to it. -! Author: P. Worley -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: unit_num ! unit number for output - integer, intent(in) :: comm_id ! MPI communicator - character(*), intent(in) :: comm_name ! MPI communicator label - - logical, intent(in), optional :: verbose - ! verbose output flag - ! (Default is .false.) - logical, intent(in), optional :: no_output - ! no output flag - ! (Default is .false.) - integer, intent(out), optional :: save_nnodes - ! return number of nodes - integer, intent(out), optional :: save_task_node_map(:) - ! return task-to-node map - -!---------------------------Local Workspace----------------------------- - integer :: iam ! task id in comm_id - integer :: npes ! number of MPI tasks in comm_id - integer :: ier ! return error status - integer :: max_len ! maximum name length - integer :: length ! node name length - integer :: c, i, j ! loop indices - integer :: nnodes ! number of nodes - integer :: start, limit ! loop bounds - integer :: head, tail ! limits of current sequential run - ! of task ids - - ! flag to indicate whether returning number of nodes - logical :: broadcast_nnodes - - ! flag to indicate whether returning task-to-node mapping - logical :: broadcast_task_node_map - - ! flag to indicate whether to use verbose or compact output format - logical :: verbose_output - - ! flag to indicate whether to write out information - ! (for when want to calculate nnodes and the task_node_map without - ! output) - logical :: output - - ! mapping of tasks to ordered list of nodes - integer, allocatable :: task_node_map(:) - - ! number of MPI tasks per node - integer, allocatable :: node_task_cnt(:) - integer, allocatable :: node_task_tmpcnt(:) - - ! MPI tasks ordered by nodes to which they are assigned - integer, allocatable :: node_task_map(:) - - ! offset into node_task_map for processes assigned to given node - integer, allocatable :: node_task_offset(:) - - logical :: masterproc ! masterproc flag - logical :: done ! search completion flag - - ! node names for each mpi task - character(len=mpi_max_processor_name) :: tmp_name - character, allocatable :: task_node_name(:) ! for this task - character, allocatable :: task_node_names(:) ! for all tasks - - ! node names without duplicates - character(len=mpi_max_processor_name), allocatable :: node_names(:) - - ! string versions of numerical values - character(len=8) :: c_npes ! number of MPI tasks - character(len=8) :: c_nnodes ! number of nodes - character(len=8) :: c_nodeid ! node id - character(len=8) :: c_node_npes ! number of MPI tasks for a given node - character(len=8) :: c_taskid ! MPI task id - - ! routine name, for error reporting - character(*),parameter :: subname = "(shr_taskmap_write)" - -!----------------------------------------------------------------------- - ! - ! Get my id - ! - call mpi_comm_rank (comm_id, iam, ier) - if (iam == 0) then - masterproc = .true. - else - masterproc = .false. - end if - - ! - ! Get number of MPI tasks - ! - call mpi_comm_size (comm_id, npes, ier) - - ! - ! Determine whether to use verbose output format - ! - verbose_output = .false. - if (present(verbose)) then - verbose_output = verbose - endif - - ! - ! Determine whether to output taskmap - ! - output = .true. - if (present(no_output)) then - if (no_output) output = .false. - endif - - ! - ! Determine whether returning number of nodes - ! - broadcast_nnodes = .false. - if (present(save_nnodes)) then - broadcast_nnodes = .true. - endif - - ! - ! Determine whether returning task-to-node mapping information - ! - broadcast_task_node_map = .false. - if (present(save_task_node_map)) then - if (size(save_task_node_map) >= npes) then - broadcast_task_node_map = .true. - else - call shr_sys_abort(trim(subname)//': array for task-to-node mapping data too small') - endif - endif - - ! - ! Allocate arrays for collecting node names - ! - max_len = mpi_max_processor_name - allocate ( task_node_name(max_len), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate task_node_name failed') - - allocate ( task_node_names(max_len*npes), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate task_node_names failed') - - ! - ! Get node names and send to root. - ! (Assume that processor names are node names.) - ! - call mpi_get_processor_name (tmp_name, length, ier) - task_node_name(:) = ' ' - do i = 1, length - task_node_name(i) = tmp_name(i:i) - end do - - ! - ! Gather node names - ! - task_node_names(:) = ' ' - call mpi_gather (task_node_name, max_len, mpi_character, & - task_node_names, max_len, mpi_character, & - 0, comm_id, ier) - - if (masterproc) then - ! - ! Identify nodes and task/node mapping. - ! - allocate ( task_node_map(0:npes-1), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate task_node_map failed') - task_node_map(:) = -1 - - allocate ( node_names(0:npes-1), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate node_names failed') - node_names(:) = ' ' - - allocate ( node_task_cnt(0:npes-1), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate node_task_cnt failed') - node_task_cnt(:) = 0 - - do c=1,max_len - tmp_name(c:c) = task_node_names(c) - enddo - - node_names(0) = trim(tmp_name) - task_node_map(0) = 0 - node_task_cnt(0) = 1 - nnodes = 1 - - do i=1,npes-1 - do c=1,max_len - tmp_name(c:c) = task_node_names(i*max_len+c) - enddo - - j = 0 - done = .false. - do while ((.not. done) .and. (j < nnodes)) - if (trim(node_names(j)) .eq. trim(tmp_name)) then - task_node_map(i) = j - node_task_cnt(j) = node_task_cnt(j) + 1 - done = .true. - endif - j = j + 1 - enddo - - if (.not. done) then - node_names(nnodes) = trim(tmp_name) - task_node_map(i) = nnodes - node_task_cnt(nnodes) = 1 - nnodes = nnodes + 1 - endif - - enddo - - ! - ! Identify node/task mapping. - ! - allocate ( node_task_offset(0:nnodes-1), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate node_task_offset failed') - node_task_offset(:) = 0 - - do j=1,nnodes-1 - node_task_offset(j) = node_task_offset(j-1) + node_task_cnt(j-1) - enddo - - allocate ( node_task_tmpcnt(0:nnodes-1), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate node_task_tmpcnt failed') - node_task_tmpcnt(:) = 0 - - allocate ( node_task_map(0:npes-1), stat=ier ) - if (ier /= 0) & - call shr_sys_abort(trim(subname)//': allocate node_task_map failed') - node_task_map(:) = -1 - - do i=0,npes-1 - j = task_node_map(i) - node_task_map(node_task_offset(j) + node_task_tmpcnt(j)) = i - node_task_tmpcnt(j) = node_task_tmpcnt(j) + 1 - enddo - - if (output) then - ! - ! Output node/task mapping - ! - write(unit_num,100) & - '--------------------------------------------------------------' -100 format(a) - - write(c_npes,'(i8)') npes - write(c_nnodes,'(i8)') nnodes - write(unit_num,101) trim(comm_name), trim(adjustl(c_nnodes)), & - trim(adjustl(c_npes)) -101 format(a,' communicator : ',a,' nodes, ',a,' MPI tasks') - - write(unit_num,100) & - 'COMMUNICATOR NODE # [NODE NAME] : (# OF MPI TASKS) TASK # LIST' - - do j=0,nnodes-1 - write(c_nodeid,'(i8)') j - write(c_node_npes,'(i8)') node_task_cnt(j) - write(unit_num,102,advance='no') & - trim(comm_name), trim(adjustl(c_nodeid)), & - trim(node_names(j)), trim(adjustl(c_node_npes)) -102 format(a,' NODE ',a,' [ ',a,' ] : ( ',a,' MPI TASKS )') - - start = node_task_offset(j) - limit = start+node_task_cnt(j)-1 - - if (verbose_output) then - - do i=start,limit - write(c_taskid,'(i8)') node_task_map(i) - write(unit_num,103,advance='no') trim(adjustl(c_taskid)) -103 format(' ',a) - enddo - - else - - head = node_task_map(start) - tail = head - do i=start+1,limit - if (node_task_map(i) == tail+1) then - tail = tail + 1 - else - write(c_taskid,'(i8)') head - write(unit_num,103,advance='no') trim(adjustl(c_taskid)) - if (head /= tail) then - write(c_taskid,'(i8)') tail - write(unit_num,104,advance='no') trim(adjustl(c_taskid)) -104 format('-',a) - endif - head = node_task_map(i) - tail = head - endif - enddo - - if (node_task_map(limit) == tail) then - write(c_taskid,'(i8)') head - write(unit_num,103,advance='no') trim(adjustl(c_taskid)) - if (head /= tail) then - write(c_taskid,'(i8)') tail - write(unit_num,104,advance='no') trim(adjustl(c_taskid)) - endif - endif - - endif - - write(unit_num,105,advance='no') -105 format(/) - enddo - write(unit_num,100) & - '--------------------------------------------------------------' - endif - - if (broadcast_nnodes) then - save_nnodes = nnodes - endif - - if (broadcast_task_node_map) then - do i=0,npes-1 - save_task_node_map(i+1) = task_node_map(i) - enddo - endif - - deallocate(node_task_map) - deallocate(node_task_tmpcnt) - deallocate(node_task_offset) - deallocate(node_task_cnt) - deallocate(node_names) - deallocate(task_node_map) - - endif - - if (broadcast_nnodes) then - call mpi_bcast(save_nnodes, 1, mpi_integer, 0, comm_id, ier) - endif - - if (broadcast_task_node_map) then - call mpi_bcast(save_task_node_map, npes, mpi_integer, 0, comm_id, ier) - endif - - deallocate(task_node_name) - deallocate(task_node_names) - - end subroutine shr_taskmap_write - -! -!======================================================================== -! -end module shr_taskmap_mod From 3877c7e6f2b6bb097a880f4382e0f08320572a60 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 15:13:04 -0600 Subject: [PATCH 08/26] add some debug print --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index e41daf3..cfba538 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -51,7 +51,8 @@ else() list(APPEND CMAKE_MODULE_PATH ${ESMFLIB}/../cmake) endif() endif() -message("ESMF cmake is ${CMAKE_MODULE_PATH}") +file(GLOB cmake_list "${ESMFLIB}/../cmake/*.cmake") +message("ESMF cmake is ${cmake_list}") find_package(ESMF REQUIRED) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") From 77eef7026d8741bb09355189e6f3c92a428d0b3c Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 15:37:22 -0600 Subject: [PATCH 09/26] add some debug print again --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index cfba538..501880a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -52,7 +52,8 @@ else() endif() endif() file(GLOB cmake_list "${ESMFLIB}/../cmake/*.cmake") -message("ESMF cmake is ${cmake_list}") +file(GLOB cmake_list2 "${ESMF_DIR}/cmake/*.cmake") +message("ESMF cmake is ${cmake_list} & ${cmake_list2}") find_package(ESMF REQUIRED) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") From 2733cde3ccb80c42f17a007c2f71b42ac2dfbe0a Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 15:49:19 -0600 Subject: [PATCH 10/26] add some debug print again and again --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 501880a..14db29a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -52,7 +52,7 @@ else() endif() endif() file(GLOB cmake_list "${ESMFLIB}/../cmake/*.cmake") -file(GLOB cmake_list2 "${ESMF_DIR}/cmake/*.cmake") +file(GLOB cmake_list2 "$ENV{ESMF_DIR}/cmake/*.cmake") message("ESMF cmake is ${cmake_list} & ${cmake_list2}") find_package(ESMF REQUIRED) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") From 1c34c6cae8d169be5b2f307ecf1b9decbfee97dd Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 17 Jun 2024 17:06:08 -0600 Subject: [PATCH 11/26] a desperate move --- CMakeLists.txt | 10 +-- cmake/FindESMF.cmake | 147 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 148 insertions(+), 9 deletions(-) create mode 100644 cmake/FindESMF.cmake diff --git a/CMakeLists.txt b/CMakeLists.txt index 14db29a..0ee9b1c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -23,7 +23,6 @@ else() project(SHARE LANGUAGES Fortran C VERSION 0.1) list(APPEND CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/cmake) endif() -message("CMAKE_MODULE_PATH is ${CMAKE_MODULE_PATH}, CMAKE_Fortran_COMPILER is ${CMAKE_Fortran_COMPILER}") enable_language(Fortran) option(WERROR "add the -Werror flag to compiler (works with gcc and intel)" OFF) @@ -45,15 +44,8 @@ endif() if (DEFINED ENV{ESMF_ROOT}) list(APPEND CMAKE_MODULE_PATH $ENV{ESMF_ROOT}/cmake) -else() - if (DEFINED ENV{ESMFMKFILE}) - get_filename_component(ESMFLIB $ENV{ESMFMKFILE} DIRECTORY CACHE) - list(APPEND CMAKE_MODULE_PATH ${ESMFLIB}/../cmake) - endif() endif() -file(GLOB cmake_list "${ESMFLIB}/../cmake/*.cmake") -file(GLOB cmake_list2 "$ENV{ESMF_DIR}/cmake/*.cmake") -message("ESMF cmake is ${cmake_list} & ${cmake_list2}") +message("ESMF cmake is ${CMAKE_MODULE_PATH}") find_package(ESMF REQUIRED) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") diff --git a/cmake/FindESMF.cmake b/cmake/FindESMF.cmake new file mode 100644 index 0000000..eabba67 --- /dev/null +++ b/cmake/FindESMF.cmake @@ -0,0 +1,147 @@ +# - Try to find ESMF +# +# Uses ESMFMKFILE to find the filepath of esmf.mk. If this is NOT set, then this +# module will attempt to find esmf.mk. If ESMFMKFILE exists, then +# ESMF_FOUND=TRUE and all ESMF makefile variables will be set in the global +# scope. Optionally, set ESMF_MKGLOBALS to a string list to filter makefile +# variables. For example, to globally scope only ESMF_LIBSDIR and ESMF_APPSDIR +# variables, use this CMake command in CMakeLists.txt: +# +# set(ESMF_MKGLOBALS "LIBSDIR" "APPSDIR") + +# Set ESMFMKFILE as defined by system env variable. If it's not explicitly set +# try to find esmf.mk file in default locations (ESMF_ROOT, CMAKE_PREFIX_PATH, +# etc) +if(NOT DEFINED ESMFMKFILE) + if(NOT DEFINED ENV{ESMFMKFILE}) + find_path(ESMFMKFILE_PATH esmf.mk PATH_SUFFIXES lib lib64) + if(ESMFMKFILE_PATH) + set(ESMFMKFILE ${ESMFMKFILE_PATH}/esmf.mk) + message(STATUS "Found esmf.mk file ${ESMFMKFILE}") + endif() + else() + set(ESMFMKFILE $ENV{ESMFMKFILE}) + endif() +endif() + +# Only parse the mk file if it is found +if(EXISTS ${ESMFMKFILE}) + set(ESMFMKFILE ${ESMFMKFILE} CACHE FILEPATH "Path to esmf.mk file") + set(ESMF_FOUND TRUE CACHE BOOL "esmf.mk file found" FORCE) + + # Read the mk file + file(STRINGS "${ESMFMKFILE}" esmfmkfile_contents) + # Parse each line in the mk file + foreach(str ${esmfmkfile_contents}) + # Only consider uncommented lines + string(REGEX MATCH "^[^#]" def ${str}) + # Line is not commented + if(def) + # Extract the variable name + string(REGEX MATCH "^[^=]+" esmf_varname ${str}) + # Extract the variable's value + string(REGEX MATCH "=.+$" esmf_vardef ${str}) + # Only for variables with a defined value + if(esmf_vardef) + # Get rid of the assignment string + string(SUBSTRING ${esmf_vardef} 1 -1 esmf_vardef) + # Remove whitespace + string(STRIP ${esmf_vardef} esmf_vardef) + # A string or single-valued list + if(NOT DEFINED ESMF_MKGLOBALS) + # Set in global scope + set(${esmf_varname} ${esmf_vardef}) + # Don't display by default in GUI + mark_as_advanced(esmf_varname) + else() # Need to filter global promotion + foreach(m ${ESMF_MKGLOBALS}) + string(FIND ${esmf_varname} ${m} match) + # Found the string + if(NOT ${match} EQUAL -1) + # Promote to global scope + set(${esmf_varname} ${esmf_vardef}) + # Don't display by default in the GUI + mark_as_advanced(esmf_varname) + # No need to search for the current string filter + break() + endif() + endforeach() + endif() + endif() + endif() + endforeach() + + # Construct ESMF_VERSION from ESMF_VERSION_STRING_GIT + # ESMF_VERSION_MAJOR and ESMF_VERSION_MINOR are defined in ESMFMKFILE + set(ESMF_VERSION 0) + set(ESMF_VERSION_PATCH ${ESMF_VERSION_REVISION}) + set(ESMF_BETA_RELEASE FALSE) + if(ESMF_VERSION_BETASNAPSHOT MATCHES "^('T')$") + set(ESMF_BETA_RELEASE TRUE) + if(ESMF_VERSION_STRING_GIT MATCHES "^ESMF.*beta_snapshot") + set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) + elseif(ESMF_VERSION_STRING_GIT MATCHES "^v.\..\..b") + set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) + else() + set(ESMF_BETA_SNAPSHOT 0) + endif() + message(STATUS "Detected ESMF Beta snapshot: ${ESMF_BETA_SNAPSHOT}") + endif() + set(ESMF_VERSION "${ESMF_VERSION_MAJOR}.${ESMF_VERSION_MINOR}.${ESMF_VERSION_PATCH}") + + # Find the ESMF library + if(USE_ESMF_STATIC_LIBS) + find_library(ESMF_LIBRARY_LOCATION NAMES libesmf.a PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) + if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") + message(WARNING "Static ESMF library (libesmf.a) not found in \ + ${ESMF_LIBSDIR}. Try setting USE_ESMF_STATIC_LIBS=OFF") + endif() + if(NOT TARGET ESMF) + add_library(ESMF STATIC IMPORTED) + endif() + else() + find_library(ESMF_LIBRARY_LOCATION NAMES esmf PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) + if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") + message(WARNING "ESMF library not found in ${ESMF_LIBSDIR}.") + endif() + if(NOT TARGET ESMF) + add_library(ESMF UNKNOWN IMPORTED) + endif() + endif() + + # Add target alias to facilitate unambiguous linking + if(NOT TARGET ESMF::ESMF) + add_library(ESMF::ESMF ALIAS ESMF) + endif() + + # Add ESMF include directories + set(ESMF_INCLUDE_DIRECTORIES "") + separate_arguments(_ESMF_F90COMPILEPATHS UNIX_COMMAND ${ESMF_F90COMPILEPATHS}) + foreach(_ITEM ${_ESMF_F90COMPILEPATHS}) + string(REGEX REPLACE "^-I" "" _ITEM "${_ITEM}") + list(APPEND ESMF_INCLUDE_DIRECTORIES ${_ITEM}) + endforeach() + + # Add ESMF link libraries + string(STRIP "${ESMF_F90LINKRPATHS} ${ESMF_F90ESMFLINKRPATHS} ${ESMF_F90ESMFLINKPATHS} ${ESMF_F90LINKPATHS} ${ESMF_F90LINKLIBS} ${ESMF_F90LINKOPTS}" ESMF_INTERFACE_LINK_LIBRARIES) + + # Finalize find_package + include(FindPackageHandleStandardArgs) + + find_package_handle_standard_args( + ${CMAKE_FIND_PACKAGE_NAME} + REQUIRED_VARS ESMF_LIBRARY_LOCATION + ESMF_INTERFACE_LINK_LIBRARIES + ESMF_F90COMPILEPATHS + VERSION_VAR ESMF_VERSION) + + set_target_properties(ESMF PROPERTIES + IMPORTED_LOCATION "${ESMF_LIBRARY_LOCATION}" + INTERFACE_INCLUDE_DIRECTORIES "${ESMF_INCLUDE_DIRECTORIES}" + INTERFACE_LINK_LIBRARIES "${ESMF_INTERFACE_LINK_LIBRARIES}") + +else() + set(ESMF_FOUND FALSE CACHE BOOL "esmf.mk file NOT found" FORCE) + message(WARNING "ESMFMKFILE ${ESMFMKFILE} not found. Try setting ESMFMKFILE \ + to esmf.mk location.") +endif() From 4fdd9a4701813db44e2ba1322baf801673c6b4a5 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 07:02:27 -0600 Subject: [PATCH 12/26] add genf90_utils to cmake dir --- cmake/genf90_utils.cmake | 90 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 cmake/genf90_utils.cmake diff --git a/cmake/genf90_utils.cmake b/cmake/genf90_utils.cmake new file mode 100644 index 0000000..2ecc81f --- /dev/null +++ b/cmake/genf90_utils.cmake @@ -0,0 +1,90 @@ +# Utility for invoking genf90 on a template file. +# +# If ENABLE_GENF90 is set to a true value, the functions here will behave +# as described below. In this case, the variable GENF90 must be defined and +# contain the genf90.pl command. +# +# If ENABLE_GENF90 is not true, no source code generation or other side +# effects will occur, but output variables will be set as if the generation +# had occurred. +# +#========================================================================== +# +# process_genf90_source_list +# +# Arguments: +# genf90_file_list - A list of template files to process. +# output_directory - Directory where generated sources will be placed. +# fortran_list_name - The name of a list used as output. +# +# Produces generated sources for each of the input templates. Then +# this function *appends* the location of each generated file to the output +# list. +# +# As a side effect, this function will add a target for each generated +# file. For a generated file named "foo.F90", the target will be named +# "generate_foo". +# +# Limitations: +# This function adds targets to work around a deficiency in CMake (see +# "declare_generated_dependencies" in Sourcelist_utils). Unfortunately, +# this means that you cannot use this function to generate two files +# with the same name in a single project. +# +#========================================================================== + +#========================================================================== +# Copyright (c) 2013-2014, University Corporation for Atmospheric Research +# +# This software is distributed under a two-clause BSD license, with no +# warranties, express or implied. See the accompanying LICENSE file for +# details. +#========================================================================== + +if(ENABLE_GENF90) + + # Notify CMake that a Fortran file can be generated from a genf90 + # template. + function(preprocess_genf90_template genf90_file fortran_file) + + add_custom_command(OUTPUT ${fortran_file} + COMMAND ${GENF90} ${genf90_file} >${fortran_file} + MAIN_DEPENDENCY ${genf90_file}) + + get_filename_component(stripped_name ${fortran_file} NAME_WE) + + add_custom_target(generate_${stripped_name} DEPENDS ${fortran_file}) + + endfunction(preprocess_genf90_template) + +else() + + # Stub if genf90 is off. + function(preprocess_genf90_template) + endfunction() + +endif() + +# Auto-generate source names. +function(process_genf90_source_list genf90_file_list output_directory + fortran_list_name) + + foreach(genf90_file IN LISTS genf90_file_list) + + # If a file is a relative path, expand it (relative to current source + # directory. + get_filename_component(genf90_file "${genf90_file}" ABSOLUTE) + + # Get extensionless base name from input. + get_filename_component(genf90_file_stripped "${genf90_file}" NAME_WE) + + # Add generated file to the test list. + set(fortran_file ${output_directory}/${genf90_file_stripped}.F90) + preprocess_genf90_template(${genf90_file} ${fortran_file}) + list(APPEND ${fortran_list_name} ${fortran_file}) + endforeach() + + # Export ${fortran_list_name} to the caller. + set(${fortran_list_name} "${${fortran_list_name}}" PARENT_SCOPE) + +endfunction(process_genf90_source_list) From d3bbb361a2d031f8a64f7562e6a4554355b3849a Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 07:24:45 -0600 Subject: [PATCH 13/26] add genf90utils to cmake dir --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 0ee9b1c..47b0d59 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -57,7 +57,7 @@ endif() file(GLOB GENF90SOURCES "src/*.F90.in") set(ENABLE_GENF90 ON) set(GENF90 "${GENF90_PATH}/genf90.pl") -include(${GENF90_PATH}/CMake/genf90_utils.cmake) +include(${CMAKE_SOURCE_DIR}/cmake/genf90_utils.cmake) process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) file(GLOB SOURCES "src/*.c" "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") list(APPEND SOURCES "${SHAREGENF90SRC}") From ff969f645101b738d46413b472312f204b18a425 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 07:53:50 -0600 Subject: [PATCH 14/26] checkout genf90 --- .github/workflows/extbuild.yml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index c54b000..a067094 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -24,6 +24,11 @@ jobs: steps: - id: checkout-share uses: actions/checkout@v4 + - id: checkout-genf90 + uses: actions/checkout@v4 + with: + path: ${GITHUB_WORKSPACE}/genf90 + repository: PARALLELIO/genf90 - id: load-env run: | sudo apt-get update @@ -69,7 +74,8 @@ jobs: pio_path: ${GITHUB_WORKSPACE}/pio src_root: ${GITHUB_WORKSPACE} cmake_flags: " -Wno-dev -DCMAKE_BUILD_TYPE=DEBUG -DWERROR=ON -DCMAKE_Fortran_FLAGS=\"-DCPRGNU -g -Wall \ - -ffree-form -ffree-line-length-none -fallow-argument-mismatch\" -DCMAKE_MODULE_PATH=$ESMF_ROOT/cmake" + -ffree-form -ffree-line-length-none -fallow-argument-mismatch\" \ + -DGENF90_PATH=${GITHUB_WORKSPACE}/genf90 -DCMAKE_MODULE_PATH=$ESMF_ROOT/cmake" - name: Test CDEPS run: | cd build-share From fc1c72416b4898c20a578a16991477f12645a0d8 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 10:33:58 -0600 Subject: [PATCH 15/26] try this one --- .github/workflows/extbuild.yml | 7 +----- CMakeLists.txt | 45 +++++++++++++++++++++++++++++----- 2 files changed, 40 insertions(+), 12 deletions(-) diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index a067094..6567f3a 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -24,11 +24,6 @@ jobs: steps: - id: checkout-share uses: actions/checkout@v4 - - id: checkout-genf90 - uses: actions/checkout@v4 - with: - path: ${GITHUB_WORKSPACE}/genf90 - repository: PARALLELIO/genf90 - id: load-env run: | sudo apt-get update @@ -75,7 +70,7 @@ jobs: src_root: ${GITHUB_WORKSPACE} cmake_flags: " -Wno-dev -DCMAKE_BUILD_TYPE=DEBUG -DWERROR=ON -DCMAKE_Fortran_FLAGS=\"-DCPRGNU -g -Wall \ -ffree-form -ffree-line-length-none -fallow-argument-mismatch\" \ - -DGENF90_PATH=${GITHUB_WORKSPACE}/genf90 -DCMAKE_MODULE_PATH=$ESMF_ROOT/cmake" + -DCMAKE_MODULE_PATH=$ESMF_ROOT/cmake" - name: Test CDEPS run: | cd build-share diff --git a/CMakeLists.txt b/CMakeLists.txt index 47b0d59..9b7d46c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -54,16 +54,49 @@ set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") if("${COMPILER}" STREQUAL "nag") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -D__NAG__") endif() -file(GLOB GENF90SOURCES "src/*.F90.in") +set(GENF90SOURCES src/shr_assert_mod.F90 src/shr_frz_mod.F90 src/shr_infnan_mod.F90) +#file(GLOB GENF90SOURCES "src/*.F90.in") set(ENABLE_GENF90 ON) + +#===== genf90 ===== +if (DEFINED GENF90_PATH) + add_custom_target(genf90 + DEPENDS ${GENF90_PATH}/genf90.pl) +else () + ExternalProject_Add (genf90 + PREFIX ${CMAKE_CURRENT_BINARY_DIR}/genf90 + GIT_REPOSITORY https://github.com/PARALLELIO/genf90 + GIT_TAG update_cmake_interface + UPDATE_COMMAND "" + CONFIGURE_COMMAND "" + BUILD_COMMAND "" + INSTALL_COMMAND "") + ExternalProject_Get_Property (genf90 SOURCE_DIR) + set (GENF90_PATH ${SOURCE_DIR}) + unset (SOURCE_DIR) +endif () + + set(GENF90 "${GENF90_PATH}/genf90.pl") -include(${CMAKE_SOURCE_DIR}/cmake/genf90_utils.cmake) -process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) +#include(${GENF90_PATH}/cmake/genf90_utils.cmake) + +#===== Fortran Source Generation with GenF90 ===== +foreach (SRC_FILE IN LISTS GENF90SOURCES) + list(APPEND SHAREGENF90SRC ${SRC_FILE}) + add_custom_command (OUTPUT ${SRC_FILE} + COMMAND ${GENF90_PATH}/genf90.pl + ${CMAKE_CURRENT_SOURCE_DIR}/${SRC_FILE}.in > ${SRC_FILE} + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${SRC_FILE}.in genf90) +endforeach () + +#process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) + file(GLOB SOURCES "src/*.c" "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") -list(APPEND SOURCES "${SHAREGENF90SRC}") +#list(APPEND SOURCES "${SHAREGENF90SRC}") #add_definitions(-DCPRINTEL) - -add_library(share STATIC ${SOURCES}) +file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/src) +add_library(share STATIC ${SOURCES} ${SHAREGENF90SRC}) +add_dependencies (share genf90) target_include_directories(share PRIVATE include RandNum/include) #target_include_directories(share PRIVATE RandNum/include) From ac08bd8d4ca22ca2d05f25ffc788f31607b9e859 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 12:58:54 -0600 Subject: [PATCH 16/26] once more with feeling --- CMakeLists.txt | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9b7d46c..b12f30e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -55,7 +55,6 @@ if("${COMPILER}" STREQUAL "nag") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -D__NAG__") endif() set(GENF90SOURCES src/shr_assert_mod.F90 src/shr_frz_mod.F90 src/shr_infnan_mod.F90) -#file(GLOB GENF90SOURCES "src/*.F90.in") set(ENABLE_GENF90 ON) #===== genf90 ===== @@ -76,9 +75,7 @@ else () unset (SOURCE_DIR) endif () - set(GENF90 "${GENF90_PATH}/genf90.pl") -#include(${GENF90_PATH}/cmake/genf90_utils.cmake) #===== Fortran Source Generation with GenF90 ===== foreach (SRC_FILE IN LISTS GENF90SOURCES) @@ -89,15 +86,12 @@ foreach (SRC_FILE IN LISTS GENF90SOURCES) DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${SRC_FILE}.in genf90) endforeach () -#process_genf90_source_list("${GENF90SOURCES}" ${CMAKE_CURRENT_BINARY_DIR} SHAREGENF90SRC) - file(GLOB SOURCES "src/*.c" "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") -#list(APPEND SOURCES "${SHAREGENF90SRC}") -#add_definitions(-DCPRINTEL) + file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/src) add_library(share STATIC ${SOURCES} ${SHAREGENF90SRC}) add_dependencies (share genf90) -target_include_directories(share PRIVATE include RandNum/include) -#target_include_directories(share PRIVATE RandNum/include) +target_include_directories(share PRIVATE include RandNum/include ${CMAKE_BINARY_DIR}) + From cb4f366492ae4d90315b7807cd2efff90874ef8c Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 13:31:39 -0600 Subject: [PATCH 17/26] ext now working, trying srt --- .github/workflows/srt.yml | 124 +++++++++----------------------------- 1 file changed, 29 insertions(+), 95 deletions(-) diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index af9cb34..e605ac1 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -39,46 +39,10 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - - name: cime checkout - uses: actions/checkout@v3 - with: - repository: ESMCI/cime - submodules: True -# - name: genf90 checkout -# uses: actions/checkout@v2 -# with: -# repository: PARALLELIO/genf90 -# path: CIME/non_py/externals/genf90 - - - name: ccs_config checkout - uses: actions/checkout@v3 - with: - repository: ESMCI/ccs_config_cesm - path: ccs_config - - - name: share checkout - uses: actions/checkout@v3 - with: - repository: ESCOMP/CESM_share - path: share - - - name: cmeps checkout - uses: actions/checkout@v3 - with: - repository: ESCOMP/CMEPS - path: components/cmeps - - - name: cdeps checkout - uses: actions/checkout@v3 - with: - repository: ESCOMP/CDEPS - path: components/cdeps - - id: load-env run: | sudo apt-get update - sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev + sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev pnetcdf-bin pnetcdf-dev libnetcdff-dev - name: Set up Python ${{ matrix.python-version }} uses: actions/setup-python@v4 @@ -88,67 +52,40 @@ jobs: - name: pip install run: pip install PyYAML - - - name: mct install - run: | - git clone -b ${{ env.MCT_VERSION }} https://github.com/MCSclimate/MCT libraries/mct - ls -l libraries/mct - - - name: parallelio install - run: | - git clone -b ${{ env.PARALLELIO_VERSION }} https://github.com/NCAR/ParallelIO libraries/parallelio - ls -l libraries/parallelio - - - name: cache pnetcdf - id: cache-pnetcdf - uses: actions/cache@v3 + - name: cesm checkout + uses: actions/checkout@v4 with: - path: ~/pnetcdf - key: ${{ runner.os }}-${{ env.PNETCDF_VERSION}}-pnetcdf-redo - - - name: pnetcdf build - if: steps.cache-pnetcdf.outputs.cache-hit != 'true' + repository: ESCOMP/CESM + path: cesm + - name: checkout submodules run: | - wget https://parallel-netcdf.github.io/Release/${{ env.PNETCDF_VERSION }}.tar.gz - tar -xzvf ${{ env.PNETCDF_VERSION }}.tar.gz - ls -l - pushd ${{ env.PNETCDF_VERSION }} - ./configure --prefix=$HOME/pnetcdf --enable-shared --disable-cxx - make - make install + pushd cesm + ./bin/git-fleximod update ccs_config cdeps mct parallelio + pushd ccs_config + git checkout main popd - - - name: Cache netcdf-fortran - id: cache-netcdf-fortran - uses: actions/cache@v3 - with: - path: ~/netcdf-fortran - key: ${{ runner.os }}-${{ env.NETCDF_FORTRAN_VERSION }}-netcdf-fortran-redo - - - name: netcdf fortran build - if: steps.cache-netcdf-fortran.outputs.cache-hit != 'true' - run: | - sudo apt-get install libnetcdf-dev - wget https://github.com/Unidata/netcdf-fortran/archive/${{ env.NETCDF_FORTRAN_VERSION }}.tar.gz - tar -xzvf ${{ env.NETCDF_FORTRAN_VERSION }}.tar.gz - ls -l - pushd netcdf-fortran-* - ./configure --prefix=$HOME/netcdf-fortran - make - make install - - - name: link netcdf-c to netcdf-fortran path - # link netcdf c library here to simplify build - run: | - pushd ${{ env.NETCDF_FORTRAN_PATH }}/include - ln -fs /usr/include/*netcdf* . - pushd ${{ env.NETCDF_FORTRAN_PATH }}/lib - clibdir=`nc-config --libdir` - ln -fs $clibdir/lib* . + git clone https://github.com/ESMCI/cime + pushd cime + if [[ ! -e "${PWD}/.gitmodules.bak" ]] + then + echo "Converting git@github.com to https://github.com urls in ${PWD}/.gitmodules" + sed -i".bak" "s/git@github.com:/https:\/\/github.com\//g" "${PWD}/.gitmodules" + fi + git submodule update --init + popd + pushd components/cdeps + git checkout main + git submodule update --init + popd + popd + - name: share checkout + uses: actions/checkout@v4 + with: + path: ~/cesm/share - name: Cache inputdata if: ${{ ! env.ACT }} - uses: actions/cache@v3 + uses: actions/cache@v4 with: path: $HOME/cesm/inputdata key: inputdata @@ -164,9 +101,6 @@ jobs: mkdir -p $HOME/cesm/inputdata cd $HOME/work/CESM_share/CESM_share ls -l $HOME/work/CESM_share/CESM_share - export NETCDF=$HOME/netcdf-fortran - export PATH=$NETCDF/bin:$PATH - export LD_LIBRARY_PATH=$NETCDF/lib:$HOME/pnetcdf/lib:$LD_LIBRARY_PATH python -m pip install pytest pytest-cov pytest -vvv --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest From 5311f45bb2fc969c211058485c6af63fd2b76fbe Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 13:53:24 -0600 Subject: [PATCH 18/26] ext now working, trying srt --- .github/workflows/srt.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index e605ac1..9b221ff 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -42,7 +42,7 @@ jobs: - id: load-env run: | sudo apt-get update - sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev pnetcdf-bin pnetcdf-dev libnetcdff-dev + sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev pnetcdf-bin libpnetcdf-dev libnetcdff-dev - name: Set up Python ${{ matrix.python-version }} uses: actions/setup-python@v4 From 2c8943460c0976396f3e05259482b5e9a79058f1 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 13:58:22 -0600 Subject: [PATCH 19/26] ext now working, trying srt 2 --- .github/workflows/srt.yml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index 9b221ff..7c4e911 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -44,14 +44,14 @@ jobs: sudo apt-get update sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev pnetcdf-bin libpnetcdf-dev libnetcdff-dev - - name: Set up Python ${{ matrix.python-version }} - uses: actions/setup-python@v4 - with: - python-version: ${{ matrix.python-version }} - cache: 'pip' - - - name: pip install - run: pip install PyYAML +# - name: Set up Python ${{ matrix.python-version }} +# uses: actions/setup-python@v4 +# with: +# python-version: ${{ matrix.python-version }} +# cache: 'pip' +# +# - name: pip install +# run: pip install PyYAML - name: cesm checkout uses: actions/checkout@v4 with: From 2987afa886d25eb3c5be1816ef722fe842bd4c1e Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 18 Jun 2024 15:04:50 -0600 Subject: [PATCH 20/26] ext now working, trying srt 2 --- .github/workflows/srt.yml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index 7c4e911..291518e 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -101,8 +101,11 @@ jobs: mkdir -p $HOME/cesm/inputdata cd $HOME/work/CESM_share/CESM_share ls -l $HOME/work/CESM_share/CESM_share - python -m pip install pytest pytest-cov - pytest -vvv --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest + pushd $GITHUB_WORKSPACE/cesm/cime/CIME/tests + ./scripts_regression_tests.py --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest + popd +# python -m pip install pytest pytest-cov +# pytest -vvv --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest # the following can be used by developers to login to the github server in case of errors # see https://github.com/marketplace/actions/debugging-with-tmate for further details From c0424fc79f8407e1268d66dcd7d57eaaec67e519 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 06:30:44 -0600 Subject: [PATCH 21/26] remove srt, strengthen ext --- .github/workflows/srt.yml | 114 -------------------------------------- CMakeLists.txt | 5 ++ 2 files changed, 5 insertions(+), 114 deletions(-) delete mode 100644 .github/workflows/srt.yml diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml deleted file mode 100644 index 291518e..0000000 --- a/.github/workflows/srt.yml +++ /dev/null @@ -1,114 +0,0 @@ -# CIME scripts regression tests - -name: scripts regression tests - -# Controls when the action will run. Triggers the workflow on push or pull request -# events but only for the master branch -on: - push: - branches: [ main ] - pull_request: - branches: [ main ] - -# A workflow run is made up of one or more jobs that can run sequentially or in parallel -jobs: - # This workflow contains a single job called "build" - build: - # The type of runner that the job will run on - runs-on: ubuntu-latest - strategy: - matrix: - python-version: [3.8, 3.9, 3.11] - env: - CC: mpicc - FC: mpifort - CXX: mpicxx - CPPFLAGS: "-I/usr/include -I/usr/local/include" - CIME_TEST_PLATFORM: ubuntu-latest - # Versions of all dependencies can be updated here - PNETCDF_VERSION: pnetcdf-1.12.3 - NETCDF_FORTRAN_VERSION: v4.6.0 - MCT_VERSION: MCT_2.11.0 - PARALLELIO_VERSION: pio2_6_2 - NETCDF_C_PATH: /usr - NETCDF_FORTRAN_PATH: ${HOME}/netcdf-fortran - PNETCDF_PATH: ${HOME}/pnetcdf - CIME_MODEL: cesm - CIME_DRIVER: nuopc - - # Steps represent a sequence of tasks that will be executed as part of the job - steps: - # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - id: load-env - run: | - sudo apt-get update - sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev pnetcdf-bin libpnetcdf-dev libnetcdff-dev - -# - name: Set up Python ${{ matrix.python-version }} -# uses: actions/setup-python@v4 -# with: -# python-version: ${{ matrix.python-version }} -# cache: 'pip' -# -# - name: pip install -# run: pip install PyYAML - - name: cesm checkout - uses: actions/checkout@v4 - with: - repository: ESCOMP/CESM - path: cesm - - name: checkout submodules - run: | - pushd cesm - ./bin/git-fleximod update ccs_config cdeps mct parallelio - pushd ccs_config - git checkout main - popd - git clone https://github.com/ESMCI/cime - pushd cime - if [[ ! -e "${PWD}/.gitmodules.bak" ]] - then - echo "Converting git@github.com to https://github.com urls in ${PWD}/.gitmodules" - sed -i".bak" "s/git@github.com:/https:\/\/github.com\//g" "${PWD}/.gitmodules" - fi - git submodule update --init - popd - pushd components/cdeps - git checkout main - git submodule update --init - popd - popd - - name: share checkout - uses: actions/checkout@v4 - with: - path: ~/cesm/share - - - name: Cache inputdata - if: ${{ ! env.ACT }} - uses: actions/cache@v4 - with: - path: $HOME/cesm/inputdata - key: inputdata -# -# The following can be used to ssh to the testnode for debugging -# see https://github.com/mxschmitt/action-tmate for details -# - name: Setup tmate session -# uses: mxschmitt/action-tmate@v3 - - - name: scripts regression tests - run: | - mkdir -p $HOME/cesm/scratch - mkdir -p $HOME/cesm/inputdata - cd $HOME/work/CESM_share/CESM_share - ls -l $HOME/work/CESM_share/CESM_share - pushd $GITHUB_WORKSPACE/cesm/cime/CIME/tests - ./scripts_regression_tests.py --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest - popd -# python -m pip install pytest pytest-cov -# pytest -vvv --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest - -# the following can be used by developers to login to the github server in case of errors -# see https://github.com/marketplace/actions/debugging-with-tmate for further details -# - name: Setup tmate session -# if: ${{ failure() }} -# uses: mxschmitt/action-tmate@v3 diff --git a/CMakeLists.txt b/CMakeLists.txt index b12f30e..eaec2b8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,6 +2,8 @@ cmake_minimum_required(VERSION 3.10) include(ExternalProject) include(FetchContent) +option(WERROR "add the -Werror flag to compiler (works with gcc and intel)" OFF) + if (DEFINED CIMEROOT) message("Using CIME in ${CIMEROOT} with compiler ${COMPILER}") include(${CASEROOT}/Macros.cmake) @@ -92,6 +94,9 @@ file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/src) add_library(share STATIC ${SOURCES} ${SHAREGENF90SRC}) add_dependencies (share genf90) target_include_directories(share PRIVATE include RandNum/include ${CMAKE_BINARY_DIR}) +if(WERROR) + target_compile_options(${COMP} PRIVATE -Werror --warn-no-unused-dummy-argument --warn-no-missing-include-dirs) +endif() From 2b05c45ddbe1ab671243fbbdca7ffc02a0084337 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 07:58:08 -0600 Subject: [PATCH 22/26] add Werror for gfortran --- CMakeLists.txt | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index eaec2b8..ab6f483 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,7 +2,8 @@ cmake_minimum_required(VERSION 3.10) include(ExternalProject) include(FetchContent) -option(WERROR "add the -Werror flag to compiler (works with gcc and intel)" OFF) +option(WERROR "add the -Werror flag to compiler (works with gnu)" OFF) +enable_language(Fortran) if (DEFINED CIMEROOT) message("Using CIME in ${CIMEROOT} with compiler ${COMPILER}") @@ -24,9 +25,18 @@ else() set(BLD_STANDALONE TRUE) project(SHARE LANGUAGES Fortran C VERSION 0.1) list(APPEND CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/cmake) + string (TOUPPER "${CMAKE_Fortran_COMPILER_ID}" CMAKE_Fortran_COMPILER_NAME) + if (CMAKE_Fortran_COMPILER_NAME STREQUAL "XL") + set (CMAKE_Fortran_COMPILER_NAME "IBM") + endif () + if (CMAKE_Fortran_COMPILER_NAME STREQUAL "INTELLLVM") + set (CMAKE_Fortran_COMPILER_NAME "INTEL") + endif () + + set (CMAKE_Fortran_COMPILER_DIRECTIVE "CPR${CMAKE_Fortran_COMPILER_NAME}" + CACHE STRING "Fortran compiler name preprocessor directive") endif() -enable_language(Fortran) - +message("CMAKE_Fortran_COMPILER_DIRECTIVE is ${CMAKE_Fortran_COMPILER_DIRECTIVE}") option(WERROR "add the -Werror flag to compiler (works with gcc and intel)" OFF) if (DEFINED ENV{PIO_ROOT}) @@ -79,6 +89,7 @@ endif () set(GENF90 "${GENF90_PATH}/genf90.pl") + #===== Fortran Source Generation with GenF90 ===== foreach (SRC_FILE IN LISTS GENF90SOURCES) list(APPEND SHAREGENF90SRC ${SRC_FILE}) @@ -88,15 +99,23 @@ foreach (SRC_FILE IN LISTS GENF90SOURCES) DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${SRC_FILE}.in genf90) endforeach () -file(GLOB SOURCES "src/*.c" "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90" "RandNum/src/*/*.c") +file(GLOB FSOURCES "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90") +file(GLOB CSOURCES "src/*.c" "RandNum/src/*/*.c") file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/src) -add_library(share STATIC ${SOURCES} ${SHAREGENF90SRC}) -add_dependencies (share genf90) -target_include_directories(share PRIVATE include RandNum/include ${CMAKE_BINARY_DIR}) + +add_library(share STATIC ${CSOURCES} ${FSOURCES} ${SHAREGENF90SRC}) + if(WERROR) - target_compile_options(${COMP} PRIVATE -Werror --warn-no-unused-dummy-argument --warn-no-missing-include-dirs) + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Werror --warn-no-unused-dummy-argument --warn-no-missing-include-dirs -ffree-line-length-none") + + set_source_files_properties(src/shr_mpi_mod.F90 src/shr_reprosum_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error;-fallow-argument-mismatch") + set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Werror -Wno-error=cpp") + endif() +add_dependencies (share genf90) +target_include_directories(share PRIVATE include RandNum/include ${CMAKE_BINARY_DIR}) +target_compile_definitions (share PUBLIC ${CMAKE_Fortran_COMPILER_DIRECTIVE}) From f10c398db9998daa10ef782492c9ee13d5ee5a0b Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 09:53:31 -0600 Subject: [PATCH 23/26] fix uninitialized var --- .github/workflows/extbuild.yml | 2 +- src/shr_assert_mod.F90.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index 6567f3a..96caacd 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -37,7 +37,7 @@ jobs: uses: actions/cache@v4 with: path: ${GITHUB_WORKSPACE}/pio - key: ${{ runner.os }}-${{ env.ParallelIO_VERSION }}-parallelio2 + key: ${{ runner.os }}-${{ env.ParallelIO_VERSION }}-pio - name: Build ParallelIO if: steps.cache-PARALLELIO.outputs.cache-hit != 'true' uses: NCAR/ParallelIO/.github/actions/parallelio_cmake@9390e30e29d4ebbfbef0fc72162cacd9e8f25e4e diff --git a/src/shr_assert_mod.F90.in b/src/shr_assert_mod.F90.in index fc62d64..6216b6e 100644 --- a/src/shr_assert_mod.F90.in +++ b/src/shr_assert_mod.F90.in @@ -81,8 +81,8 @@ subroutine shr_assert(var, msg, file, line) character(len=:), allocatable :: full_msg + full_msg = 'ERROR' if (.not. var) then - full_msg = 'ERROR' if (present(file)) then full_msg = full_msg // ' in ' // trim(file) if (present(line)) then From 2fc46751e3622e93fcc7c8c11c629b2699784c2a Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 10:11:52 -0600 Subject: [PATCH 24/26] try again --- CMakeLists.txt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index ab6f483..ae15e8b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -110,8 +110,10 @@ if(WERROR) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Werror --warn-no-unused-dummy-argument --warn-no-missing-include-dirs -ffree-line-length-none") set_source_files_properties(src/shr_mpi_mod.F90 src/shr_reprosum_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error;-fallow-argument-mismatch") + # This flag seems to be needed for temp variables generated by the compiler version in jammy + set_source_files_properties(src/shr_assert_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error=maybe-uninitialized") set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Werror -Wno-error=cpp") - + endif() add_dependencies (share genf90) target_include_directories(share PRIVATE include RandNum/include ${CMAKE_BINARY_DIR}) From fcfe513fcf10b245f47a8ec609f876df3081ae54 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 10:36:53 -0600 Subject: [PATCH 25/26] try again --- CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index ae15e8b..bf3f61d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -113,6 +113,7 @@ if(WERROR) # This flag seems to be needed for temp variables generated by the compiler version in jammy set_source_files_properties(src/shr_assert_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error=maybe-uninitialized") set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Werror -Wno-error=cpp") + set_source_files_properties(src/shr_cal_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error=conversion") endif() add_dependencies (share genf90) From a7d1e947d251a013bed2faeabae61653f74da2a8 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 10:45:44 -0600 Subject: [PATCH 26/26] cpp unused functions --- src/shr_spfn_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/shr_spfn_mod.F90 b/src/shr_spfn_mod.F90 index 4b8c98e..669bebf 100644 --- a/src/shr_spfn_mod.F90 +++ b/src/shr_spfn_mod.F90 @@ -440,7 +440,7 @@ end function shr_spfn_gamma_r8 ! Latest modification: March 19, 1990 ! !------------------------------------------------------------------ - +#ifndef HAVE_ERF_INTRINSICS SUBROUTINE CALERF_r8(ARG, RESULT, JINT) !------------------------------------------------------------------ @@ -752,7 +752,6 @@ SUBROUTINE CALERF_r4(ARG, RESULT, JINT) END IF 80 continue end SUBROUTINE CALERF_r4 - !------------------------------------------------------------------------------------------ !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -988,6 +987,7 @@ pure function shr_spfn_gamma_nonintrinsic_r8(X) result(gamma) gamma = res ! ---------- LAST LINE OF GAMMA ---------- end function shr_spfn_gamma_nonintrinsic_r8 +#endif !! Incomplete Gamma function !!