From 9272f196954d26993feec213e626329c1b743d86 Mon Sep 17 00:00:00 2001 From: mvertens Date: Tue, 16 Nov 2021 11:02:30 -0700 Subject: [PATCH 01/45] Merge pull request #256 from mvertens/feature/refactor_directories cmeps directory refactor ### Description of changes CMEPS directory refactor ### Specific notes The following directory changes were made: - util/ => ufs/ - nuopc_cap_share => cesm/nuopc_cap_share/ - share/src/shr_flux_mod => cesm/flux_atmocn/shr_flux_mod (cesm only) - share/cmeps/* => cesm/nuopc_cap_share (cesm only) Also shr_constants_mod.F90 is now only used by cesm and the the file util/shr_const_mod.F90 has been moved and renamed to ufs/ufs_constants_mod.F90 In addition med_aofluxes_mod.F90 now has separate calls to the ufs and cesm atmocn flux computation. Contributors other than yourself, if any: CMEPS Issues Fixed: None Are changes expected to change answers? bit-for-bit Any User Interface Changes (namelist or namelist defaults changes)? No Testing performed: CESM testing: verified that the following tests are bfb with cesm2_3_alpha07a on cheyenne : IRT_Ld7.f09_g17.BHIST.cheyenne_intel.allactive-defaultio ERS_Ld3.f45_g37_rx1.A.cheyenne_intel UFS testing: ufs-weather-model [0cf60348](https://github.com/ufs-community/ufs-weather-model) using CMEPS e703499 --- src/nuopc_shr_methods.F90 | 839 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 839 insertions(+) create mode 100644 src/nuopc_shr_methods.F90 diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 new file mode 100644 index 00000000..421606fd --- /dev/null +++ b/src/nuopc_shr_methods.F90 @@ -0,0 +1,839 @@ +module nuopc_shr_methods + + use ESMF , only : operator(<), operator(/=), operator(+) + use ESMF , only : operator(-), operator(*) , operator(>=) + use ESMF , only : operator(<=), operator(>), operator(==) + use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_LogFoundError, ESMF_LOGMSG_ERROR, ESMF_MAXSTR + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_State, ESMF_StateGet + use ESMF , only : ESMF_Field, ESMF_FieldGet + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSet + use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldStatus_Flag + use ESMF , only : ESMF_Mesh, ESMF_MeshGet + use ESMF , only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_COMPLETE + use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet + use ESMF , only : ESMF_ClockPrint, ESMF_ClockAdvance + use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet, ESMF_AlarmSet + use ESMF , only : ESMF_Calendar, ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN + use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet + use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet, ESMF_TimeIntervalGet + use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast, ESMF_VMGetCurrent + use NUOPC , only : NUOPC_CompAttributeGet + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_file_mod , only : shr_file_setlogunit, shr_file_getLogUnit + + implicit none + private + + public :: memcheck + public :: get_component_instance + public :: set_component_logging + public :: log_clock_advance + public :: state_getscalar + public :: state_setscalar + public :: state_diagnose + public :: alarmInit + public :: chkerr + + private :: timeInit + private :: field_getfldptr + + ! Clock and alarm options + character(len=*), private, parameter :: & + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nsteps" , & + optNStep = "nstep" , & + optNSeconds = "nseconds" , & + optNSecond = "nsecond" , & + optNMinutes = "nminutes" , & + optNMinute = "nminute" , & + optNHours = "nhours" , & + optNHour = "nhour" , & + optNDays = "ndays" , & + optNDay = "nday" , & + optNMonths = "nmonths" , & + optNMonth = "nmonth" , & + optNYears = "nyears" , & + optNYear = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optEnd = "end" , & + optDate = "date" + + + ! Module data + integer, parameter :: SecPerDay = 86400 ! Seconds per day + integer, parameter :: memdebug_level=1 + character(len=1024) :: msgString + character(len=*), parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine memcheck(string, level, mastertask) + + ! input/output variables + character(len=*) , intent(in) :: string + integer , intent(in) :: level + logical , intent(in) :: mastertask + + ! local variables + integer :: ierr +#ifdef CESMCOUPLED + integer, external :: GPTLprint_memusage +#endif + !----------------------------------------------------------------------- + +#ifdef CESMCOUPLED + if ((mastertask .and. memdebug_level > level) .or. memdebug_level > level+1) then + ierr = GPTLprint_memusage(string) + endif +#endif + + end subroutine memcheck + +!=============================================================================== + + subroutine get_component_instance(gcomp, inst_suffix, inst_index, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(out) :: inst_suffix + integer , intent(out) :: inst_index + integer , intent(out) :: rc + + ! local variables + logical :: isPresent + character(len=4) :: cvalue + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", value=inst_suffix, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + cvalue = inst_suffix(2:) + read(cvalue, *) inst_index + else + inst_suffix = "" + inst_index=1 + endif + + end subroutine get_component_instance + +!=============================================================================== + + subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + logical, intent(in) :: mastertask + integer, intent(out) :: logunit + integer, intent(out) :: shrlogunit + integer, intent(out) :: rc + + ! local variables + character(len=CL) :: diro + character(len=CL) :: logfile + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + shrlogunit = 6 + + if (mastertask) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) + else + logUnit = 6 + endif + + call shr_file_setLogUnit (logunit) + + end subroutine set_component_logging + +!=============================================================================== + + subroutine log_clock_advance(clock, component, logunit, rc) + + ! input/output variables + type(ESMF_Clock) :: clock + character(len=*) , intent(in) :: component + integer , intent(in) :: logunit + integer , intent(out) :: rc + + ! local variables + character(len=CL) :: cvalue, prestring + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + write(prestring, *) "------>Advancing ",trim(component)," from: " + call ESMF_ClockPrint(clock, options="currTime", unit=cvalue, preString=trim(prestring), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(logunit, *) trim(cvalue) + + call ESMF_ClockPrint(clock, options="stopTime", unit=cvalue, & + preString="--------------------------------> to: ", rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(logunit, *) trim(cvalue) + + end subroutine log_clock_advance + +!=============================================================================== + + subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Get scalar data from State for a particular name and broadcast it to all other pets + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + integer, intent(in) :: scalar_id + real(r8), intent(out) :: scalar_value + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask, ierr, len + type(ESMF_VM) :: vm + type(ESMF_Field) :: field + real(r8), pointer :: farrayptr(:,:) + real(r8) :: tmp(1) + character(len=*), parameter :: subname='(state_getscalar)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=field, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(field, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + endif + tmp(:) = farrayptr(scalar_id,:) + endif + call ESMF_VMBroadCast(vm, tmp, 1, 0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + scalar_value = tmp(1) + + end subroutine state_getscalar + +!================================================================================ + + subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Set scalar data from State for a particular name + ! ---------------------------------------------- + + ! input/output arguments + real(r8), intent(in) :: scalar_value + integer, intent(in) :: scalar_id + type(ESMF_State), intent(inout) :: State + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask + type(ESMF_Field) :: lfield + type(ESMF_VM) :: vm + real(r8), pointer :: farrayptr(:,:) + character(len=*), parameter :: subname='(state_setscalar)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(lfield, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif + farrayptr(scalar_id,1) = scalar_value + endif + + end subroutine state_setscalar + +!=============================================================================== + + subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: string + integer , intent(out) :: rc + + ! local variables + integer :: i,j,n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(r8), pointer :: dataPtr1d(:) + real(r8), pointer :: dataPtr2d(:,:) + character(len=*),parameter :: subname='(state_diagnose)' + ! ---------------------------------------------- + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do n = 1, fieldCount + + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,a)') trim(string)//': for 1d field '//trim(lfieldnamelist(n)) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + write(msgString,'(A,3g14.7,i8)') trim(string)//': 1d field '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,a)') trim(string)//': for 2d field '//trim(lfieldnamelist(n)) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + write(msgString,'(A,3g14.7,i8)') trim(string)//': 2d field '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + enddo + + deallocate(lfieldnamelist) + + end subroutine state_diagnose + +!=============================================================================== + + subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! ---------------------------------------------- + ! for a field, determine rank and return fldptr1 or fldptr2 + ! abort is true by default and will abort if fldptr is not yet allocated in field + ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(r8), pointer , intent(inout), optional :: fldptr1(:) + real(r8), pointer , intent(inout), optional :: fldptr2(:,:) + integer , intent(out) , optional :: rank + logical , intent(in) , optional :: abort + integer , intent(out) , optional :: rc + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname='(field_getfldptr)' + ! ---------------------------------------------- + + if (.not.present(rc)) then + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (status /= ESMF_FIELDSTATUS_COMPLETE) then + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + endif + else + + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + endif ! status + + if (present(rank)) then + rank = lrank + endif + + end subroutine field_getfldptr + +!=============================================================================== + + subroutine alarmInit( clock, alarm, option, & + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + + ! Setup an alarm in a clock + ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm + ! time. If you send an arbitrary but proper ringtime from the + ! past and the ring interval, the alarm will always go off on the + ! next clock advance and this will cause serious problems. Even + ! if it makes sense to initialize an alarm with some reference + ! time and the alarm interval, that reference time has to be + ! advance forward to be >= the current time. In the logic below + ! we set an appropriate "NextAlarm" and then we make sure to + ! advance it properly based on the ring interval. + + ! input/output variables + type(ESMF_Clock) , intent(inout) :: clock ! clock + type(ESMF_Alarm) , intent(inout) :: alarm ! alarm + character(len=*) , intent(in) :: option ! alarm option + integer , optional , intent(in) :: opt_n ! alarm freq + integer , optional , intent(in) :: opt_ymd ! alarm ymd + integer , optional , intent(in) :: opt_tod ! alarm tod (sec) + type(ESMF_Time) , optional , intent(in) :: RefTime ! ref time + character(len=*) , optional , intent(in) :: alarmname ! alarm name + integer , intent(inout) :: rc ! Return code + + ! local variables + type(ESMF_Calendar) :: cal ! calendar + integer :: lymd ! local ymd + integer :: ltod ! local tod + integer :: cyy,cmm,cdd,csec ! time info + character(len=64) :: lalarmname ! local alarm name + logical :: update_nextalarm ! update next alarm + type(ESMF_Time) :: CurrTime ! Current Time + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + integer :: sec + character(len=*), parameter :: subname = '(set_alarmInit): ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + lalarmname = 'alarm_unknown' + if (present(alarmname)) lalarmname = trim(alarmname) + ltod = 0 + if (present(opt_tod)) ltod = opt_tod + lymd = -1 + if (present(opt_ymd)) lymd = opt_ymd + + call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! initial guess of next alarm, this will be updated below + if (present(RefTime)) then + NextAlarm = RefTime + else + NextAlarm = CurrTime + endif + + ! Determine calendar + call ESMF_ClockGet(clock, calendar=cal) + + ! Determine inputs for call to create alarm + selectcase (trim(option)) + + case (optNONE) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optNever) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optEnd) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optDate) + if (.not. present(opt_ymd)) then + call shr_sys_abort(subname//trim(option)//' requires opt_ymd') + end if + if (lymd < 0 .or. ltod < 0) then + call shr_sys_abort(subname//trim(option)//'opt_ymd, opt_tod invalid') + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call timeInit(NextAlarm, lymd, cal, ltod, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optNSteps) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNStep) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNSeconds) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNSecond) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinutes) + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinute) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHours) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHour) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDays) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDay) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonths) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonth) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optMonthly) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optNYears) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNYear) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optYearly) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case default + call shr_sys_abort(subname//'unknown option '//trim(option)) + + end select + + ! -------------------------------------------------------------------------------- + ! --- AlarmInterval and NextAlarm should be set --- + ! -------------------------------------------------------------------------------- + + ! --- advance Next Alarm so it won't ring on first timestep for + ! --- most options above. go back one alarminterval just to be careful + + if (update_nextalarm) then + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo + endif + alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & + ringInterval=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine alarmInit + +!=============================================================================== + + subroutine timeInit( Time, ymd, cal, tod, rc) + + ! Create the ESMF_Time object corresponding to the given input time, + ! given in YMD (Year Month Day) and TOD (Time-of-day) format. + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + + ! input/output parameters: + type(ESMF_Time) , intent(inout) :: Time ! ESMF time + integer , intent(in) :: ymd ! year, month, day YYYYMMDD + type(ESMF_Calendar) , intent(in) :: cal ! ESMF calendar + integer , intent(in) :: tod ! time of day in seconds + integer , intent(out) :: rc + + ! local variables + integer :: year, mon, day ! year, month, day as integers + integer :: tdate ! temporary date + character(len=*), parameter :: subname='(timeInit)' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if ( (ymd < 0) .or. (tod < 0) .or. (tod > SecPerDay) )then + call shr_sys_abort( subname//'ERROR yymmdd is a negative number or time-of-day out of bounds' ) + end if + + tdate = abs(ymd) + year = int(tdate/10000) + if (ymd < 0) year = -year + mon = int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + + call ESMF_TimeSet( Time, yy=year, mm=mon, dd=day, s=tod, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine timeInit + +!=============================================================================== + + logical function chkerr(rc, line, file) + + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + + integer :: lrc + + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif + end function chkerr + +end module nuopc_shr_methods From 693605d1bcf10535a6ebe94c169a52171bf105f9 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Fri, 15 Apr 2022 10:56:32 -0600 Subject: [PATCH 02/45] Merge pull request #275 from jedwards4b/modelio_to_runconfig ### Description of changes Update shr_pio_mod, removing mct centric initialization. Improve logging and make sure logs go to the correct component. Depends on cime branch async_io_in_esmf ### Specific notes Contributors other than yourself, if any: CMEPS Issues Fixed (include github issue #): Are changes expected to change answers? bfb Any User Interface Changes (namelist or namelist defaults changes)? The modelio namelist has been eliminated and the parameters from that file were moved to nuopc.runconfig, The xml variable PIO_ASYNC_INTERFACE was changed from a global variable to one that could be set individually for each component. ### Testing performed Testing performed if application target is CESM: - [X] (recommended) CIME_DRIVER=nuopc scripts_regression_tests.py - machines: cheyenne intel - details (e.g. failed tests): IRT_N2_Vmct_Ln9.f19_g16_rx1.A.cheyenne_intel fails, apparently expected. - [ ] (recommended) CESM testlist_drv.xml - machines and compilers: - details (e.g. failed tests): - [x] (optional) CESM prealpha test - machines and compilers - details (e.g. failed tests): - [ ] (other) please described in detail - machines and compilers - details (e.g. failed tests): Testing performed if application target is UFS-coupled: - [ ] (recommended) UFS-coupled testing - description: - details (e.g. failed tests): Testing performed if application target is UFS-HAFS: - [ ] (recommended) UFS-HAFS testing - description: - details (e.g. failed tests): ### Hashes used for testing: - [ ] CESM: - repository to check out: https://github.com/ESCOMP/CESM.git - branch/hash: - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: - [ ] UFS-HAFS, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: --- src/nuopc_shr_methods.F90 | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 421606fd..da7891c4 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -132,7 +132,7 @@ end subroutine get_component_instance !=============================================================================== subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) - + use shr_pio_mod, only : shr_pio_log_comp_settings ! input/output variables type(ESMF_GridComp) :: gcomp logical, intent(in) :: mastertask @@ -143,6 +143,8 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) ! local variables character(len=CL) :: diro character(len=CL) :: logfile + character(len=CL) :: inst_suffix + integer :: inst_index ! not used here !----------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -154,14 +156,23 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + call get_component_instance(gcomp, inst_suffix, inst_index, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Multiinstance logfile name needs a correction + if(logfile(4:4) == '_') then + logfile = logfile(1:3)//trim(inst_suffix)//logfile(9:) + endif open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) + ! Write the PIO settings to the beggining of each component log + call shr_pio_log_comp_settings(gcomp, logunit) + else logUnit = 6 endif - + ! TODO: shr_file mod is deprecated and should be removed. call shr_file_setLogUnit (logunit) - + end subroutine set_component_logging !=============================================================================== From 847bdcb97dfd3d523fe67b0170a4656e241ef041 Mon Sep 17 00:00:00 2001 From: Bill Sacks Date: Fri, 8 Jul 2022 11:49:29 -0600 Subject: [PATCH 03/45] Merge pull request #306 from billsacks/fix_lilac_pio2 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Extract non-initialization parts of shr_pio_mod to a module in share ### Description of changes Extract the non-initialization parts of shr_pio_mod to a module in the share repository, just keeping the initialization parts here. This is part of a set of changes where I am splitting shr_pio_mod into two pieces: (1) Reading configuration files and initializing PIO appropriately (2) Storing information about PIO (io system descriptors, io types, io formats) and providing an interface to query this information Piece (2) lives in the share code and is used regardless of the driver. Piece (1) is driver-specific, so for now we have three versions of that piece: one in CMEPS (created by extracting the initialization pieces from `cmeps/src/shr_pio_mod.F90`), one in the cpl7 repo (created by extracting the initialization pieces from `share/src/shr_pio_mod.F90`), and one in CTSM's LILAC directory (which is essentially identical to the one in the cpl7 repo). Piece (2) – the actual share code piece – is used by components (their use statements stay exactly as they are now) as well as by piece (1) (which is responsible for setting the module-level variables in piece (2)). See https://github.com/ESCOMP/CTSM/issues/1759#issuecomment-1171779485 for more context. Needs to be coordinated with https://github.com/ESCOMP/CESM_share/pull/34 ### Specific notes Contributors other than yourself, if any: Discussions with @jedwards4b @mvertens CMEPS Issues Fixed (include github issue #): none Are changes expected to change answers? no Any User Interface Changes (namelist or namelist defaults changes)? no ### Testing performed **Only limited testing performed so far; I plan to run CESM prealpha testing. Please let me know if you'd like more than that (I'm uncertain about whether scripts_regression_tests and testlist_drv give additional value if I'm already running prealpha testing).** Testing performed if application target is CESM: - [ ] (recommended) CIME_DRIVER=nuopc scripts_regression_tests.py - machines: - details (e.g. failed tests): - [ ] (recommended) CESM testlist_drv.xml - machines and compilers: - details (e.g. failed tests): - [x] (optional) CESM prealpha test - machines and compilers: cheyenne intel & gnu - details (e.g. failed tests): tests pass and are bit-for-bit - [x] (other) please described in detail: the following tests pass ``` ERP_D_Ld10_P36x2_Vmct.f10_f10_mg37.IHistClm51BgcCrop.cheyenne_intel.clm-ciso_decStart ERP_D_P36x2_Ld3.f10_f10_mg37.I1850Clm50BgcCrop.cheyenne_intel.clm-default LILACSMOKE_D_Ld2.f10_f10_mg37.I2000Ctsm50NwpSpAsRs.cheyenne_intel.clm-lilac ``` Testing performed if application target is UFS-coupled: - [ ] (recommended) UFS-coupled testing - description: - details (e.g. failed tests): Testing performed if application target is UFS-HAFS: - [ ] (recommended) UFS-HAFS testing - description: - details (e.g. failed tests): ### Hashes used for testing: - [x] CESM prealpha tests: - repository to check out: https://github.com/ESCOMP/CESM.git - branch/hash: cesm2_3_alpha09c, but with: cmeps at 1f8ce1304a7c0939cbc4584e1b5afa5165821fb6, cpl7 at 15c5d5ce45a9db320b1448e5c29d9892fc57e046 and share at d7c43983b8d84abfc357fa112870bc50b3b60d60 (all from billsacks forks) - [x] For the other tests described above: - repository to check out: https://github.com/billsacks/CTSM.git - branch/hash: branch fix_lilac_pio2, hash 2ead6826d - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: - [ ] UFS-HAFS, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: --- src/nuopc_shr_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index da7891c4..8d472902 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -132,7 +132,7 @@ end subroutine get_component_instance !=============================================================================== subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) - use shr_pio_mod, only : shr_pio_log_comp_settings + use driver_pio_mod, only : driver_pio_log_comp_settings ! input/output variables type(ESMF_GridComp) :: gcomp logical, intent(in) :: mastertask @@ -165,7 +165,7 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) ! Write the PIO settings to the beggining of each component log - call shr_pio_log_comp_settings(gcomp, logunit) + call driver_pio_log_comp_settings(gcomp, logunit) else logUnit = 6 From 9fdbe54823289a7097acf5cbdcb093186bc79939 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Fri, 7 Oct 2022 10:18:48 -0600 Subject: [PATCH 04/45] Merge pull request #305 from jedwards4b/jedwards/asyncio first step - reorder pio_init and move to ensemble_driver ### Description of changes Add an InitializeIO phase to the ensemble_driver, this allows ESMF to control the ASYNCIO tasks internally. ### Specific notes It requires however that components do not do IO initialization until the realize phase so the cice and mosart component PRs: https://github.com/ESCOMP/MOSART/pull/55 https://github.com/ESCOMP/CICE/pull/18 must be merged first. --- src/nuopc_shr_methods.F90 | 36 +++++++++++++++++++++++++----------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 8d472902..c001bd3b 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -22,7 +22,6 @@ module nuopc_shr_methods use NUOPC_Model , only : NUOPC_ModelGet use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cs=>shr_kind_cs use shr_sys_mod , only : shr_sys_abort - use shr_file_mod , only : shr_file_setlogunit, shr_file_getLogUnit implicit none private @@ -132,7 +131,10 @@ end subroutine get_component_instance !=============================================================================== subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + use NUOPC, only : NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd + use ESMF, only : ESMF_GridCompGet, ESMF_LOGMSG_INFO, ESMF_LogWrite use driver_pio_mod, only : driver_pio_log_comp_settings + ! input/output variables type(ESMF_GridComp) :: gcomp logical, intent(in) :: mastertask @@ -144,7 +146,9 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) character(len=CL) :: diro character(len=CL) :: logfile character(len=CL) :: inst_suffix + character(len=CL) :: name integer :: inst_index ! not used here + character(len=*), parameter :: subname = "("//__FILE__//": set_component_logging)" !----------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -164,15 +168,25 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) endif open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - ! Write the PIO settings to the beggining of each component log - call driver_pio_log_comp_settings(gcomp, logunit) + ! Write the PIO settings to the beggining of each component log + call driver_pio_log_comp_settings(gcomp, logunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return else logUnit = 6 endif - ! TODO: shr_file mod is deprecated and should be removed. - call shr_file_setLogUnit (logunit) + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(subname)//": setting logunit for component: "//trim(name), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeAdd(gcomp, attrList=(/'logunit'/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, name='logunit',value=logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end subroutine set_component_logging !=============================================================================== @@ -225,7 +239,7 @@ subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, fld type(ESMF_Field) :: field real(r8), pointer :: farrayptr(:,:) real(r8) :: tmp(1) - character(len=*), parameter :: subname='(state_getscalar)' + character(len=*), parameter :: subname = '('//__FILE__//':state_getscalar)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -276,7 +290,7 @@ subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, fld type(ESMF_Field) :: lfield type(ESMF_VM) :: vm real(r8), pointer :: farrayptr(:,:) - character(len=*), parameter :: subname='(state_setscalar)' + character(len=*), parameter :: subname = '('//__FILE__//':state_setscalar)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -322,7 +336,7 @@ subroutine state_diagnose(State, string, rc) character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) real(r8), pointer :: dataPtr1d(:) real(r8), pointer :: dataPtr2d(:,:) - character(len=*),parameter :: subname='(state_diagnose)' + character(len=*), parameter :: subname = '('//__FILE__//':state_diagnose)' ! ---------------------------------------------- call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) @@ -399,7 +413,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) type(ESMF_Mesh) :: lmesh integer :: lrank, nnodes, nelements logical :: labort - character(len=*), parameter :: subname='(field_getfldptr)' + character(len=*), parameter :: subname = '('//__FILE__//':field_getfldptr)' ! ---------------------------------------------- if (.not.present(rc)) then @@ -526,7 +540,7 @@ subroutine alarmInit( clock, alarm, option, & type(ESMF_Time) :: NextAlarm ! Next restart alarm time type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval integer :: sec - character(len=*), parameter :: subname = '(set_alarmInit): ' + character(len=*), parameter :: subname = '('//__FILE__//':alarmInit)' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -810,7 +824,7 @@ subroutine timeInit( Time, ymd, cal, tod, rc) ! local variables integer :: year, mon, day ! year, month, day as integers integer :: tdate ! temporary date - character(len=*), parameter :: subname='(timeInit)' + character(len=*), parameter :: subname = '('//__FILE__//':timeInit)' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS From 9c57bbfff79e6842621593c52a48dfdd2a79cb97 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 12 Oct 2022 10:31:37 -0600 Subject: [PATCH 05/45] Merge pull request #315 from ESCOMP/revert-305-jedwards/asyncio Revert "first step - reorder pio_init and move to ensemble_driver" --- src/nuopc_shr_methods.F90 | 36 +++++++++++------------------------- 1 file changed, 11 insertions(+), 25 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index c001bd3b..8d472902 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -22,6 +22,7 @@ module nuopc_shr_methods use NUOPC_Model , only : NUOPC_ModelGet use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cs=>shr_kind_cs use shr_sys_mod , only : shr_sys_abort + use shr_file_mod , only : shr_file_setlogunit, shr_file_getLogUnit implicit none private @@ -131,10 +132,7 @@ end subroutine get_component_instance !=============================================================================== subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) - use NUOPC, only : NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd - use ESMF, only : ESMF_GridCompGet, ESMF_LOGMSG_INFO, ESMF_LogWrite use driver_pio_mod, only : driver_pio_log_comp_settings - ! input/output variables type(ESMF_GridComp) :: gcomp logical, intent(in) :: mastertask @@ -146,9 +144,7 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) character(len=CL) :: diro character(len=CL) :: logfile character(len=CL) :: inst_suffix - character(len=CL) :: name integer :: inst_index ! not used here - character(len=*), parameter :: subname = "("//__FILE__//": set_component_logging)" !----------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -168,25 +164,15 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) endif open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - ! Write the PIO settings to the beggining of each component log - call driver_pio_log_comp_settings(gcomp, logunit, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + call driver_pio_log_comp_settings(gcomp, logunit) + else logUnit = 6 endif - + ! TODO: shr_file mod is deprecated and should be removed. + call shr_file_setLogUnit (logunit) - call ESMF_GridCompGet(gcomp, name=name, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - call ESMF_LogWrite(trim(subname)//": setting logunit for component: "//trim(name), ESMF_LOGMSG_INFO) - - call NUOPC_CompAttributeAdd(gcomp, attrList=(/'logunit'/), rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name='logunit',value=logunit, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end subroutine set_component_logging !=============================================================================== @@ -239,7 +225,7 @@ subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, fld type(ESMF_Field) :: field real(r8), pointer :: farrayptr(:,:) real(r8) :: tmp(1) - character(len=*), parameter :: subname = '('//__FILE__//':state_getscalar)' + character(len=*), parameter :: subname='(state_getscalar)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -290,7 +276,7 @@ subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, fld type(ESMF_Field) :: lfield type(ESMF_VM) :: vm real(r8), pointer :: farrayptr(:,:) - character(len=*), parameter :: subname = '('//__FILE__//':state_setscalar)' + character(len=*), parameter :: subname='(state_setscalar)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -336,7 +322,7 @@ subroutine state_diagnose(State, string, rc) character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) real(r8), pointer :: dataPtr1d(:) real(r8), pointer :: dataPtr2d(:,:) - character(len=*), parameter :: subname = '('//__FILE__//':state_diagnose)' + character(len=*),parameter :: subname='(state_diagnose)' ! ---------------------------------------------- call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) @@ -413,7 +399,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) type(ESMF_Mesh) :: lmesh integer :: lrank, nnodes, nelements logical :: labort - character(len=*), parameter :: subname = '('//__FILE__//':field_getfldptr)' + character(len=*), parameter :: subname='(field_getfldptr)' ! ---------------------------------------------- if (.not.present(rc)) then @@ -540,7 +526,7 @@ subroutine alarmInit( clock, alarm, option, & type(ESMF_Time) :: NextAlarm ! Next restart alarm time type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval integer :: sec - character(len=*), parameter :: subname = '('//__FILE__//':alarmInit)' + character(len=*), parameter :: subname = '(set_alarmInit): ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -824,7 +810,7 @@ subroutine timeInit( Time, ymd, cal, tod, rc) ! local variables integer :: year, mon, day ! year, month, day as integers integer :: tdate ! temporary date - character(len=*), parameter :: subname = '('//__FILE__//':timeInit)' + character(len=*), parameter :: subname='(timeInit)' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS From 419bd0fc3bb1a49f2f0defaa18b635e4d7636628 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 30 Nov 2022 15:21:43 -0700 Subject: [PATCH 06/45] Merge pull request #322 from jedwards4b/LL_fldList ### Description of changes Make the med_fldList fields a linked list instead of an array. This avoids a lot of small allocations and memory fragmentation. ### Specific notes Contributors other than yourself, if any: Denise CMEPS Issues Fixed: #321 Are changes expected to change answers? bfb Any User Interface Changes (namelist or namelist defaults changes)? ### Testing performed Testing performed if application target is CESM: - [X] (recommended) CIME_DRIVER=nuopc scripts_regression_tests.py - machines: cheyenne, intel - details (e.g. failed tests): all pass - [ ] (recommended) CESM testlist_drv.xml - machines and compilers: - details (e.g. failed tests): - [X] (optional) CESM prealpha test - machines and compilers cheyenne, intel - details (e.g. failed tests): All pass except expected fails of cesm2_3_alpha10c - [ ] (other) please described in detail - machines and compilers - details (e.g. failed tests): Testing performed if application target is UFS-coupled: - [X] (recommended) UFS-coupled testing - description: gnu and intel - details (e.g. failed tests): Testing performed if application target is UFS-HAFS: - [ ] (recommended) UFS-HAFS testing - description: - details (e.g. failed tests): ### Hashes used for testing: - [ ] CESM: - repository to check out: https://github.com/ESCOMP/CESM.git - branch/hash: - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: - [ ] UFS-HAFS, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: --- src/nuopc_shr_methods.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 8d472902..1a6c43c2 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -149,8 +149,6 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) rc = ESMF_SUCCESS - shrlogunit = 6 - if (mastertask) then call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -170,7 +168,8 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) else logUnit = 6 endif - ! TODO: shr_file mod is deprecated and should be removed. + shrlogunit = logunit + call shr_file_setLogUnit (logunit) end subroutine set_component_logging From 841a70cf5d34fcbb3758d707211be1d4ce039b1d Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 5 Dec 2022 11:05:10 -0700 Subject: [PATCH 07/45] Merge pull request #323 from jedwards4b/shr_file_to_shr_log move shr_file_getLogUnit to shr_log_getLogUnit ### Description of changes Clean up usage of log files ### Specific notes Depricated shr_file_getLogUnit and added shr_log_getLogUnit Depends on https://github.com/ESCOMP/CESM_share/pull/36 Contributors other than yourself, if any: CMEPS Issues Fixed (include github issue #): Are changes expected to change answers? (specify if bfb, different at roundoff, more substantial) Any User Interface Changes (namelist or namelist defaults changes)? ### Testing performed Testing performed if application target is CESM: - [ ] (recommended) CIME_DRIVER=nuopc scripts_regression_tests.py - machines: - details (e.g. failed tests): - [ ] (recommended) CESM testlist_drv.xml - machines and compilers: - details (e.g. failed tests): - [X] (optional) CESM prealpha test - machines and compilers cheyenne intel - details (e.g. failed tests): all consistant with baselines. - [ ] (other) please described in detail - machines and compilers - details (e.g. failed tests): Testing performed if application target is UFS-coupled: - [ ] (recommended) UFS-coupled testing - description: - details (e.g. failed tests): Testing performed if application target is UFS-HAFS: - [ ] (recommended) UFS-HAFS testing - description: - details (e.g. failed tests): ### Hashes used for testing: - [ ] CESM: - repository to check out: https://github.com/ESCOMP/CESM.git - branch/hash: - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: - [ ] UFS-HAFS, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: --- src/nuopc_shr_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 1a6c43c2..0ed53f22 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -22,7 +22,7 @@ module nuopc_shr_methods use NUOPC_Model , only : NUOPC_ModelGet use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cs=>shr_kind_cs use shr_sys_mod , only : shr_sys_abort - use shr_file_mod , only : shr_file_setlogunit, shr_file_getLogUnit + use shr_log_mod , only : shr_log_setLogUnit implicit none private @@ -170,7 +170,7 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) endif shrlogunit = logunit - call shr_file_setLogUnit (logunit) + call shr_log_setLogUnit (logunit) end subroutine set_component_logging From e3280cf9adc152f2d142246dbe8f3e0e6a32c277 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 10 Jan 2023 09:14:00 -0700 Subject: [PATCH 08/45] Merge pull request #336 from jedwards4b/master_to_main replace use of master with main --- src/nuopc_shr_methods.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 0ed53f22..cfa2b00e 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -75,12 +75,12 @@ module nuopc_shr_methods contains !=============================================================================== - subroutine memcheck(string, level, mastertask) + subroutine memcheck(string, level, maintask) ! input/output variables character(len=*) , intent(in) :: string integer , intent(in) :: level - logical , intent(in) :: mastertask + logical , intent(in) :: maintask ! local variables integer :: ierr @@ -90,7 +90,7 @@ subroutine memcheck(string, level, mastertask) !----------------------------------------------------------------------- #ifdef CESMCOUPLED - if ((mastertask .and. memdebug_level > level) .or. memdebug_level > level+1) then + if ((maintask .and. memdebug_level > level) .or. memdebug_level > level+1) then ierr = GPTLprint_memusage(string) endif #endif @@ -131,11 +131,11 @@ end subroutine get_component_instance !=============================================================================== - subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) use driver_pio_mod, only : driver_pio_log_comp_settings ! input/output variables type(ESMF_GridComp) :: gcomp - logical, intent(in) :: mastertask + logical, intent(in) :: maintask integer, intent(out) :: logunit integer, intent(out) :: shrlogunit integer, intent(out) :: rc @@ -149,7 +149,7 @@ subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) rc = ESMF_SUCCESS - if (mastertask) then + if (maintask) then call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) From 7d09252f3ec6b7d5eb72ba8bf2f485c3b8d0b458 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 11 Jan 2023 13:45:06 -0700 Subject: [PATCH 09/45] Merge pull request #337 from jedwards4b/esmf_multidriver redo multiinstance support --- src/nuopc_shr_methods.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index cfa2b00e..3d50906d 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -145,6 +145,7 @@ subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) character(len=CL) :: logfile character(len=CL) :: inst_suffix integer :: inst_index ! not used here + integer :: n !----------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -157,8 +158,9 @@ subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) call get_component_instance(gcomp, inst_suffix, inst_index, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Multiinstance logfile name needs a correction - if(logfile(4:4) == '_') then - logfile = logfile(1:3)//trim(inst_suffix)//logfile(9:) + if(len_trim(inst_suffix) > 0) then + n = index(logfile, '.') + logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:) endif open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) From 045c1a737ea9f0e3296a4c8dac5b8098f9bdc6be Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Thu, 26 Jan 2023 09:22:20 -0700 Subject: [PATCH 10/45] Merge pull request #325 from jedwards4b/pio_asyncio_in_cmeps enable asyncio using pio ### Description of changes Allows IO tasks to be independent of compute tasks in cesm ### Specific notes (testing in progress) Contributors other than yourself, if any: Depends on share (https://github.com/ESCOMP/CESM_share/pull/37) and cime (https://github.com/ESMCI/cime/pull/4340). CMEPS Issues Fixed (include github issue #): Are changes expected to change answers? (specify if bfb, different at roundoff, more substantial) Any User Interface Changes (namelist or namelist defaults changes)? ### Testing performed Testing performed if application target is CESM: - [ ] (recommended) CIME_DRIVER=nuopc scripts_regression_tests.py - machines: - details (e.g. failed tests): - [ ] (recommended) CESM testlist_drv.xml - machines and compilers: - details (e.g. failed tests): - [X] (optional) CESM prealpha test - machines and compilers cheyenne intel - details (e.g. failed tests): results consistant with cesm2_3_alpha10d - [ ] (other) please described in detail - machines and compilers - details (e.g. failed tests): Testing performed if application target is UFS-coupled: - [ ] (recommended) UFS-coupled testing - description: - details (e.g. failed tests): Testing performed if application target is UFS-HAFS: - [X] (recommended) UFS-HAFS testing - description: - details (e.g. failed tests): ### Hashes used for testing: - [ ] CESM: - repository to check out: https://github.com/ESCOMP/CESM.git - branch/hash: - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: - [ ] UFS-HAFS, then umbrella repostiory to check out and associated hash: - repository to check out: - branch/hash: --- src/nuopc_shr_methods.F90 | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 3d50906d..9062b27f 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -130,9 +130,8 @@ subroutine get_component_instance(gcomp, inst_suffix, inst_index, rc) end subroutine get_component_instance !=============================================================================== - subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) - use driver_pio_mod, only : driver_pio_log_comp_settings + use NUOPC, only: NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd ! input/output variables type(ESMF_GridComp) :: gcomp logical, intent(in) :: maintask @@ -144,8 +143,10 @@ subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) character(len=CL) :: diro character(len=CL) :: logfile character(len=CL) :: inst_suffix - integer :: inst_index ! not used here + integer :: inst_index ! Not used here integer :: n + character(len=CL) :: name + character(len=*), parameter :: subname = "("//__FILE__//": set_component_logging)" !----------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -164,16 +165,23 @@ subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) endif open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - ! Write the PIO settings to the beggining of each component log - call driver_pio_log_comp_settings(gcomp, logunit) else logUnit = 6 endif - shrlogunit = logunit + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(subname)//": setting logunit for component: "//trim(name), ESMF_LOGMSG_INFO) + call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, "logunit", logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call shr_log_setLogUnit (logunit) - + ! Still need to set this return value + shrlogunit = logunit + call ESMF_LogWrite(trim(subname)//": done for component "//trim(name), ESMF_LOGMSG_INFO) end subroutine set_component_logging !=============================================================================== From 4a3a5c16eacdc5c29d7955fede85a056cc3993c0 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Fri, 29 Mar 2024 14:10:42 -0600 Subject: [PATCH 11/45] now its working --- src/nuopc_shr_methods.F90 | 223 ++++++++++++++++---------------------- 1 file changed, 91 insertions(+), 132 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 9062b27f..7c251cfa 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -35,36 +35,35 @@ module nuopc_shr_methods public :: state_setscalar public :: state_diagnose public :: alarmInit + public :: get_minimum_timestep public :: chkerr private :: timeInit private :: field_getfldptr - ! Clock and alarm options - character(len=*), private, parameter :: & - optNONE = "none" , & - optNever = "never" , & - optNSteps = "nsteps" , & - optNStep = "nstep" , & - optNSeconds = "nseconds" , & - optNSecond = "nsecond" , & - optNMinutes = "nminutes" , & - optNMinute = "nminute" , & - optNHours = "nhours" , & - optNHour = "nhour" , & - optNDays = "ndays" , & - optNDay = "nday" , & - optNMonths = "nmonths" , & - optNMonth = "nmonth" , & - optNYears = "nyears" , & - optNYear = "nyear" , & - optMonthly = "monthly" , & - optYearly = "yearly" , & + ! Module data + + ! Clock and alarm options shared with esm_time_mod along with dtime_driver which is initialized there. + ! Dtime_driver is needed here for setting alarm options which use the nstep option and is a module variable + ! to avoid requiring a change in all model caps. + character(len=*), public, parameter :: & + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nstep" , & + optNSeconds = "nsecond" , & + optNMinutes = "nminute" , & + optNHours = "nhour" , & + optNDays = "nday" , & + optNMonths = "nmonth" , & + optNYears = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & optEnd = "end" , & - optDate = "date" - + optGLCCouplingPeriod = "glc_coupling_period" - ! Module data + integer, public :: dtime_drv ! initialized in esm_time_mod.F90 + integer, parameter :: SecPerDay = 86400 ! Seconds per day integer, parameter :: memdebug_level=1 character(len=1024) :: msgString @@ -566,21 +565,7 @@ subroutine alarmInit( clock, alarm, option, & ! Determine inputs for call to create alarm selectcase (trim(option)) - case (optNONE) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. - - case (optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. - - case (optEnd) + case (optNONE, optNever, optEnd) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) @@ -600,39 +585,15 @@ subroutine alarmInit( clock, alarm, option, & if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. - case (optNSteps) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNStep) + case (optNSteps, trim(optNSteps)//'s') if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNSeconds) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n + ! variable dtime_drv is the smallest component timestep, set in esm_time_mod.F90 + call ESMF_TimeIntervalSet(AlarmInterval, s=dtime_drv, rc=rc ) + AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. - case (optNSecond) + case (optNSeconds, trim(optNSeconds)//'s') if (.not.present(opt_n)) then call shr_sys_abort(subname//trim(option)//' requires opt_n') end if @@ -644,7 +605,7 @@ subroutine alarmInit( clock, alarm, option, & AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. - case (optNMinutes) + case (optNMinutes, trim(optNMinutes)//'s') call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) if (.not.present(opt_n)) then call shr_sys_abort(subname//trim(option)//' requires opt_n') @@ -655,19 +616,7 @@ subroutine alarmInit( clock, alarm, option, & AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. - case (optNMinute) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNHours) + case (optNHours, trim(optNHours)//'s') if (.not.present(opt_n)) then call shr_sys_abort(subname//trim(option)//' requires opt_n') end if @@ -679,31 +628,7 @@ subroutine alarmInit( clock, alarm, option, & AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. - case (optNHour) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNDays) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNDay) + case (optNDays, trim(optNDays)//'s') if (.not.present(opt_n)) then call shr_sys_abort(subname//trim(option)//' requires opt_n') end if @@ -715,19 +640,7 @@ subroutine alarmInit( clock, alarm, option, & AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. - case (optNMonths) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNMonth) + case (optNMonths, trim(optNMonths)//'s') if (.not.present(opt_n)) then call shr_sys_abort(subname//trim(option)//' requires opt_n') end if @@ -746,19 +659,7 @@ subroutine alarmInit( clock, alarm, option, & if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. - case (optNYears) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNYear) + case (optNYears, trim(optNYears)//'s') if (.not.present(opt_n)) then call shr_sys_abort(subname//trim(option)//' requires opt_n') end if @@ -839,6 +740,64 @@ subroutine timeInit( Time, ymd, cal, tod, rc) end subroutine timeInit +!=============================================================================== + + integer function get_minimum_timestep(gcomp, rc) + type(ESMF_GridComp), intent(in) :: gcomp + integer, intent(out) :: rc + + character(len=CS) :: cvalue + integer :: atm_cpl_dt ! Atmosphere coupling interval + integer :: lnd_cpl_dt ! Land coupling interval + integer :: ice_cpl_dt ! Sea-Ice coupling interval + integer :: ocn_cpl_dt ! Ocean coupling interval + integer :: glc_cpl_dt ! Glc coupling interval + integer :: rof_cpl_dt ! Runoff coupling interval + integer :: wav_cpl_dt ! Wav coupling interval + + ! integer :: esp_cpl_dt ! Esp coupling interval + + !--------------------------------------------------------------------------- + ! Determine driver clock timestep + !--------------------------------------------------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name="atm_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) atm_cpl_dt + + call NUOPC_CompAttributeGet(gcomp, name="lnd_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) lnd_cpl_dt + + call NUOPC_CompAttributeGet(gcomp, name="ice_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) ice_cpl_dt + + call NUOPC_CompAttributeGet(gcomp, name="ocn_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) ocn_cpl_dt + + call NUOPC_CompAttributeGet(gcomp, name="glc_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) glc_cpl_dt + + call NUOPC_CompAttributeGet(gcomp, name="rof_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) rof_cpl_dt + + call NUOPC_CompAttributeGet(gcomp, name="wav_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) wav_cpl_dt + + get_minimum_timestep = minval((/atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt/)) + if(get_minimum_timestep <= 0) then + print *,__FILE__,__LINE__,atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt + call ESMF_LogWrite('minimum_timestep_error ERROR ', ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + end function get_minimum_timestep + !=============================================================================== logical function chkerr(rc, line, file) From 8c37d81e0937043b333cb58bf618c238b240d641 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 1 Apr 2024 08:49:29 -0600 Subject: [PATCH 12/45] update github workflow --- .github/workflows/srt.yml | 55 ++++++++++++++++++++++++++++++--------- 1 file changed, 43 insertions(+), 12 deletions(-) diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index af9cb34a..6b51263a 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -26,15 +26,15 @@ jobs: 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 + PNETCDF_VERSION: pnetcdf-1.13.0 + NETCDF_FORTRAN_VERSION: v4.6.1 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 + ESMF_VERSION: v8.6.1b03 # Steps represent a sequence of tasks that will be executed as part of the job steps: @@ -89,15 +89,15 @@ 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: 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 @@ -146,6 +146,37 @@ jobs: clibdir=`nc-config --libdir` ln -fs $clibdir/lib* . + - name: Cache PARALLELIO + id: cache-PARALLELIO + uses: actions/cache@v3 + 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: Cache inputdata if: ${{ ! env.ACT }} uses: actions/cache@v3 From cfa7f68af003604f2dcf51c054836a7001d71fd0 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 1 Apr 2024 11:39:30 -0600 Subject: [PATCH 13/45] add error checking --- src/nuopc_shr_methods.F90 | 92 +++++++++++++++++++++++++++++++-------- 1 file changed, 75 insertions(+), 17 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 7c251cfa..eb8a3989 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -743,6 +743,8 @@ end subroutine timeInit !=============================================================================== integer function get_minimum_timestep(gcomp, rc) + ! Get the minimum timestep interval in seconds based on the nuopc.config variables *_cpl_dt, + ! if none of these variables are defined this routine will throw an error type(ESMF_GridComp), intent(in) :: gcomp integer, intent(out) :: rc @@ -754,42 +756,98 @@ integer function get_minimum_timestep(gcomp, rc) integer :: glc_cpl_dt ! Glc coupling interval integer :: rof_cpl_dt ! Runoff coupling interval integer :: wav_cpl_dt ! Wav coupling interval - - ! integer :: esp_cpl_dt ! Esp coupling interval + logical :: is_present, is_set ! determine if these variables are used + integer :: esp_cpl_dt ! Esp coupling interval !--------------------------------------------------------------------------- ! Determine driver clock timestep !--------------------------------------------------------------------------- + get_minimum_timestep = huge(1) - call NUOPC_CompAttributeGet(gcomp, name="atm_cpl_dt", value=cvalue, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="atm_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) atm_cpl_dt - call NUOPC_CompAttributeGet(gcomp, name="lnd_cpl_dt", value=cvalue, rc=rc) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="atm_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) atm_cpl_dt + get_minimum_timestep = min(atm_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="lnd_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) lnd_cpl_dt - call NUOPC_CompAttributeGet(gcomp, name="ice_cpl_dt", value=cvalue, rc=rc) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="lnd_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) lnd_cpl_dt + get_minimum_timestep = min(lnd_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="ice_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) ice_cpl_dt - call NUOPC_CompAttributeGet(gcomp, name="ocn_cpl_dt", value=cvalue, rc=rc) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="ice_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) ice_cpl_dt + get_minimum_timestep = min(ice_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="ocn_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) ocn_cpl_dt - call NUOPC_CompAttributeGet(gcomp, name="glc_cpl_dt", value=cvalue, rc=rc) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="ocn_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) ocn_cpl_dt + get_minimum_timestep = min(ocn_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="glc_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) glc_cpl_dt - call NUOPC_CompAttributeGet(gcomp, name="rof_cpl_dt", value=cvalue, rc=rc) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="glc_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) glc_cpl_dt + get_minimum_timestep = min(glc_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="rof_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) rof_cpl_dt - call NUOPC_CompAttributeGet(gcomp, name="wav_cpl_dt", value=cvalue, rc=rc) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="rof_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) rof_cpl_dt + get_minimum_timestep = min(rof_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="wav_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="wav_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) wav_cpl_dt + get_minimum_timestep = min(wav_cpl_dt, get_minimum_timestep) + endif + + call NUOPC_CompAttributeGet(gcomp, name="esp_cpl_dt", isPresent=is_present, isSet=is_set, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) wav_cpl_dt - get_minimum_timestep = minval((/atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt/)) + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name="esp_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) esp_cpl_dt + get_minimum_timestep = min(esp_cpl_dt, get_minimum_timestep) + endif + if(get_minimum_timestep == huge(1)) then + call ESMF_LogWrite('minimum_timestep_error: this option is not supported ', ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif if(get_minimum_timestep <= 0) then print *,__FILE__,__LINE__,atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt call ESMF_LogWrite('minimum_timestep_error ERROR ', ESMF_LOGMSG_ERROR) From b2f2be16b1da3b262437aa28244e1b895aa9594a Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 1 Apr 2024 16:02:58 -0600 Subject: [PATCH 14/45] fix issue with REST_OPTION=end --- src/nuopc_shr_methods.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index eb8a3989..93e5abe5 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -15,7 +15,7 @@ module nuopc_shr_methods use ESMF , only : ESMF_ClockPrint, ESMF_ClockAdvance use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet, ESMF_AlarmSet use ESMF , only : ESMF_Calendar, ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN - use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet + use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet, ESMF_ClockGetAlarm use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet, ESMF_TimeIntervalGet use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast, ESMF_VMGetCurrent use NUOPC , only : NUOPC_CompAttributeGet @@ -568,8 +568,10 @@ subroutine alarmInit( clock, alarm, option, & case (optNONE, optNever, optEnd) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, "alarm_stop", alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AlarmGet(alarm, ringTime=NextAlarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. case (optDate) From 79e18ab86cc6a9acd28b859df1a949a195fab0a5 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Thu, 4 Apr 2024 15:39:09 -0600 Subject: [PATCH 15/45] all alarmInit function handled here now --- src/nuopc_shr_methods.F90 | 206 +++++++++++++++++++++----------------- 1 file changed, 115 insertions(+), 91 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 93e5abe5..196d6d6f 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -2,7 +2,7 @@ module nuopc_shr_methods use ESMF , only : operator(<), operator(/=), operator(+) use ESMF , only : operator(-), operator(*) , operator(>=) - use ESMF , only : operator(<=), operator(>), operator(==) + use ESMF , only : operator(<=), operator(>), operator(==), MOD use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_LogFoundError, ESMF_LOGMSG_ERROR, ESMF_MAXSTR use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE use ESMF , only : ESMF_State, ESMF_StateGet @@ -499,7 +499,7 @@ end subroutine field_getfldptr !=============================================================================== subroutine alarmInit( clock, alarm, option, & - opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + opt_n, opt_ymd, opt_tod, RefTime, alarmname, advance_clock, rc) ! Setup an alarm in a clock ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm @@ -521,6 +521,7 @@ subroutine alarmInit( clock, alarm, option, & integer , optional , intent(in) :: opt_tod ! alarm tod (sec) type(ESMF_Time) , optional , intent(in) :: RefTime ! ref time character(len=*) , optional , intent(in) :: alarmname ! alarm name + logical , optional , intent(in) :: advance_clock ! advance clock to trigger alarm integer , intent(inout) :: rc ! Return code ! local variables @@ -533,8 +534,9 @@ subroutine alarmInit( clock, alarm, option, & type(ESMF_Time) :: CurrTime ! Current Time type(ESMF_Time) :: NextAlarm ! Next restart alarm time type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + type(ESMF_TimeInterval) :: TimeStepInterval ! Component timestep interval integer :: sec - character(len=*), parameter :: subname = '(set_alarmInit): ' + character(len=*), parameter :: subname = '(alarmInit): ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS @@ -562,126 +564,134 @@ subroutine alarmInit( clock, alarm, option, & ! Determine calendar call ESMF_ClockGet(clock, calendar=cal) + ! Error checks + if (trim(option) == optdate) then + if (.not. present(opt_ymd)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + end if + if (lymd < 0 .or. ltod < 0) then + call ESMF_LogWrite(subname//trim(option)//'opt_ymd, opt_tod invalid', ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + end if + else if (& + trim(option) == optNSteps .or. trim(option) == trim(optNSteps)//'s' .or. & + trim(option) == optNSeconds .or. trim(option) == trim(optNSeconds)//'s' .or. & + trim(option) == optNMinutes .or. trim(option) == trim(optNMinutes)//'s' .or. & + trim(option) == optNHours .or. trim(option) == trim(optNHours)//'s' .or. & + trim(option) == optNDays .or. trim(option) == trim(optNDays)//'s' .or. & + trim(option) == optNMonths .or. trim(option) == trim(optNMonths)//'s' .or. & + trim(option) == optNYears .or. trim(option) == trim(optNYears)//'s' ) then + if (.not.present(opt_n)) then + call ESMF_LogWrite(subname//trim(option)//' requires opt_n', ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + end if + if (opt_n <= 0) then + call ESMF_LogWrite(subname//trim(option)//' invalid opt_n', ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + end if + end if ! Determine inputs for call to create alarm selectcase (trim(option)) - case (optNONE, optNever, optEnd) + case (optNONE) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGetAlarm(clock, "alarm_stop", alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_AlarmGet(alarm, ringTime=NextAlarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. - case (optDate) - if (.not. present(opt_ymd)) then - call shr_sys_abort(subname//trim(option)//' requires opt_ymd') - end if - if (lymd < 0 .or. ltod < 0) then - call shr_sys_abort(subname//trim(option)//'opt_ymd, opt_tod invalid') - end if + case (optNever) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call timeInit(NextAlarm, lymd, cal, ltod, rc) + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. - case (optNSteps, trim(optNSteps)//'s') - if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') - if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') - ! variable dtime_drv is the smallest component timestep, set in esm_time_mod.F90 - call ESMF_TimeIntervalSet(AlarmInterval, s=dtime_drv, rc=rc ) - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNSeconds, trim(optNSeconds)//'s') - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNMinutes, trim(optNMinutes)//'s') - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. +! case (optEnd) +! call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) +! if (chkerr(rc,__LINE__,u_FILE_u)) return +! call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) +! if (chkerr(rc,__LINE__,u_FILE_u)) return +! update_nextalarm = .false. - case (optNHours, trim(optNHours)//'s') - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + case (optDate) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNDays, trim(optNDays)//'s') - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + call timeInit(NextAlarm, lymd, cal, ltod, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + update_nextalarm = .false. - case (optNMonths, trim(optNMonths)//'s') - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + case (optNSteps,trim(optNSteps)//'s') + call ESMF_ClockGet(clock, TimeStep=TimestepInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalSet(AlarmInterval, s=dtime_drv, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + ! timestepinterval*0 is 0 of kind ESMF_TimeStepInterval + if (mod(AlarmInterval, TimestepInterval) /= (timestepinterval*0)) then + call ESMF_LogWrite(subname//'illegal Alarm setting for '//trim(alarmname), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + update_nextalarm = .true. + + case (optNSeconds,trim(optNSeconds)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinutes,trim(optNMinutes)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHours,trim(optNHours)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDays,trim(optNDays)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonths,trim(optNMonths)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optMonthly) call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. case (optNYears, trim(optNYears)//'s') - if (.not.present(opt_n)) then - call shr_sys_abort(subname//trim(option)//' requires opt_n') - end if - if (opt_n <= 0) then - call shr_sys_abort(subname//trim(option)//' invalid opt_n') - end if call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optYearly) call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. - case default - call shr_sys_abort(subname//'unknown option '//trim(option)) + call ESMF_LogWrite(subname//'unknown option '//trim(option), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return end select @@ -702,6 +712,20 @@ subroutine alarmInit( clock, alarm, option, & ringInterval=AlarmInterval, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Advance model clock to trigger alarm then reset model clock back to currtime + if (present(advance_clock)) then + if (advance_clock) then + call ESMF_AlarmSet(alarm, clock=clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(clock, currTime=CurrTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockAdvance(clock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockSet(clock, currTime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + end subroutine alarmInit !=============================================================================== From f4f1d9f193cb4b2a1705e25f0881aeca8ec17e68 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Sat, 6 Apr 2024 08:40:18 -0600 Subject: [PATCH 16/45] some cleanup --- src/nuopc_shr_methods.F90 | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 196d6d6f..469c45d3 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -9,7 +9,7 @@ module nuopc_shr_methods use ESMF , only : ESMF_Field, ESMF_FieldGet use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSet use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldStatus_Flag - use ESMF , only : ESMF_Mesh, ESMF_MeshGet + use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_AlarmSet use ESMF , only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_COMPLETE use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet use ESMF , only : ESMF_ClockPrint, ESMF_ClockAdvance @@ -61,7 +61,7 @@ module nuopc_shr_methods optDate = "date" , & optEnd = "end" , & optGLCCouplingPeriod = "glc_coupling_period" - + integer, public :: dtime_drv ! initialized in esm_time_mod.F90 integer, parameter :: SecPerDay = 86400 ! Seconds per day @@ -500,7 +500,7 @@ end subroutine field_getfldptr subroutine alarmInit( clock, alarm, option, & opt_n, opt_ymd, opt_tod, RefTime, alarmname, advance_clock, rc) - + use ESMF, only : ESMF_AlarmPrint ! Setup an alarm in a clock ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm ! time. If you send an arbitrary but proper ringtime from the @@ -560,7 +560,7 @@ subroutine alarmInit( clock, alarm, option, & else NextAlarm = CurrTime endif - + ! Determine calendar call ESMF_ClockGet(clock, calendar=cal) @@ -595,6 +595,7 @@ subroutine alarmInit( clock, alarm, option, & return end if end if + ! Determine inputs for call to create alarm selectcase (trim(option)) @@ -612,13 +613,6 @@ subroutine alarmInit( clock, alarm, option, & if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. -! case (optEnd) -! call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) -! if (chkerr(rc,__LINE__,u_FILE_u)) return -! call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) -! if (chkerr(rc,__LINE__,u_FILE_u)) return -! update_nextalarm = .false. - case (optDate) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -711,7 +705,7 @@ subroutine alarmInit( clock, alarm, option, & alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & ringInterval=AlarmInterval, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - + ! Advance model clock to trigger alarm then reset model clock back to currtime if (present(advance_clock)) then if (advance_clock) then From 18deed90fc25a3ab64f8428752e13a43ff4fedec Mon Sep 17 00:00:00 2001 From: James Edwards Date: Wed, 10 Apr 2024 15:18:49 -0500 Subject: [PATCH 17/45] try updating pio bld tag --- .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 6b51263a..3684a91e 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -154,7 +154,7 @@ jobs: 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 + uses: NCAR/ParallelIO/.github/actions/parallelio_cmake@pio2_6_2 with: parallelio_version: ${{ env.ParallelIO_VERSION }} enable_fortran: True From 70f327f48b1fc75964474c01f0a0098940d132ba Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Fri, 14 Jun 2024 13:54:23 -0600 Subject: [PATCH 18/45] 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 00000000..af2dfbd5 --- /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 f68be557..9e83e335 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 8a2fc597..00000000 --- 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 d20f69e6..00000000 --- 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 2d066d07..00000000 --- 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 9d10b9eb..fb61f424 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 19/45] 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 00000000..913e9520 --- /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 00000000..ecb32eba --- /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 af2dfbd5..edd3ef1d 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 d2748057..00000000 --- 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 11f79a6a..00000000 --- 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 c9bebb29..00000000 --- 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 8c78ef58..00000000 --- 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 435ca8d0..00000000 --- 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 46f80485..00000000 --- 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 e4202b78..00000000 --- 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 af7f3f2e..00000000 --- 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 3442e31d..00000000 --- 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 d3da7ea0..00000000 --- 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 5467bdf3..00000000 --- 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 082bbc27..00000000 --- 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 9147996f..00000000 --- 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 921727bb..00000000 --- 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 4d4935b7..00000000 --- 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 d2e61291..00000000 --- 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 dcae37f7..00000000 --- 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 e8c73ef5..00000000 --- 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 874a0b4e..00000000 --- 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 77641ffb..00000000 --- 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 e94ded97..00000000 --- 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 c723ae20..00000000 --- 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 e7b0ee62..00000000 --- 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 1bec99c9..00000000 --- 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 7706964d..00000000 --- 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 3852ebca..00000000 --- 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 03f5a6a2..00000000 --- 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 567cac85..00000000 --- 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 a0996501..00000000 --- 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 1538fd0f..00000000 --- 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 a60131ff..00000000 --- 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 0b67c007..00000000 --- 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 b10ac410..00000000 --- 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 70ab49fa..00000000 --- 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 7ac6300c..00000000 --- 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 09975fca..00000000 --- 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 a2b0eefd..00000000 --- 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 dc87e614..00000000 --- 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 0dde5118..00000000 --- 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 6e47a27a..00000000 --- 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 85f9e251..00000000 --- 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 5302be4f..00000000 --- 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 1e4bb150..00000000 --- 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 674eda17..00000000 --- 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 60a5ef7d..00000000 --- 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 20/45] 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 913e9520..7f9a4653 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 21/45] 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 edd3ef1d..b41d7427 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 ab872a27..50bdaae5 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 22/45] try again --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index b41d7427..e2c9696f 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 23/45] try this --- CMakeLists.txt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index e2c9696f..e41daf36 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 24/45] 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 ecb32eba..c54b0009 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 8ddcccb9..00000000 --- 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 f7ad1677..00000000 --- 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 b89df748..bf463d55 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 02151a40..00000000 --- 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 25/45] add some debug print --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index e41daf36..cfba5385 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 26/45] add some debug print again --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index cfba5385..501880af 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 27/45] 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 501880af..14db29a8 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 28/45] 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 14db29a8..0ee9b1cb 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 00000000..eabba677 --- /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 29/45] 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 00000000..2ecc81f5 --- /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 30/45] add genf90utils to cmake dir --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 0ee9b1cb..47b0d59b 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 31/45] 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 c54b0009..a0670949 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 32/45] 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 a0670949..6567f3a0 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 47b0d59b..9b7d46cd 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 33/45] once more with feeling --- CMakeLists.txt | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9b7d46cd..b12f30e5 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 34/45] 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 af9cb34a..e605ac17 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 35/45] 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 e605ac17..9b221fff 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 36/45] 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 9b221fff..7c4e911c 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 37/45] 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 7c4e911c..291518e2 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 38/45] 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 291518e2..00000000 --- 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 b12f30e5..eaec2b8d 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 39/45] add Werror for gfortran --- CMakeLists.txt | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index eaec2b8d..ab6f483f 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 40/45] 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 6567f3a0..96caacdb 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 fc62d64b..6216b6e2 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 41/45] try again --- CMakeLists.txt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index ab6f483f..ae15e8b5 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 42/45] try again --- CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index ae15e8b5..bf3f61da 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 43/45] 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 4b8c98e3..669bebf8 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 !! From 78dc67ee7adbbf84bc8848622da8c12df115c32b Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 19 Jun 2024 11:10:51 -0600 Subject: [PATCH 44/45] fix warnings in nuopc_shr_methods --- src/nuopc_shr_methods.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/nuopc_shr_methods.F90 b/src/nuopc_shr_methods.F90 index 469c45d3..2752379f 100644 --- a/src/nuopc_shr_methods.F90 +++ b/src/nuopc_shr_methods.F90 @@ -82,7 +82,6 @@ subroutine memcheck(string, level, maintask) logical , intent(in) :: maintask ! local variables - integer :: ierr #ifdef CESMCOUPLED integer, external :: GPTLprint_memusage #endif @@ -228,7 +227,7 @@ subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, fld integer, intent(inout) :: rc ! local variables - integer :: mytask, ierr, len + integer :: mytask type(ESMF_VM) :: vm type(ESMF_Field) :: field real(r8), pointer :: farrayptr(:,:) @@ -324,7 +323,7 @@ subroutine state_diagnose(State, string, rc) integer , intent(out) :: rc ! local variables - integer :: i,j,n + integer :: n type(ESMf_Field) :: lfield integer :: fieldCount, lrank character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) @@ -535,7 +534,6 @@ subroutine alarmInit( clock, alarm, option, & type(ESMF_Time) :: NextAlarm ! Next restart alarm time type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval type(ESMF_TimeInterval) :: TimeStepInterval ! Component timestep interval - integer :: sec character(len=*), parameter :: subname = '(alarmInit): ' !------------------------------------------------------------------------------- From e4b48690229a1b41248427efb4456df128842b1f Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Thu, 20 Jun 2024 08:04:42 -0600 Subject: [PATCH 45/45] fix unit tests, all now pass on derecho with ESMF_ROOT=$NCAR_ROOT_ESMF ./scripts/fortran_unit_testing/run_tests.py --build-dir `pwd`/ftest --- src/CMakeLists.txt | 52 ++++++--------------------- test/unit/shr_cal_test/CMakeLists.txt | 3 ++ 2 files changed, 13 insertions(+), 42 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 9e83e335..789aa922 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,31 +1,9 @@ -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}") @@ -44,25 +22,15 @@ list(APPEND share_sources shr_string_mod.F90 shr_timer_mod.F90 shr_vmath_mod.F90 - shr_wv_sat_mod.F90) - -# Build a separate list containing the mct wrapper and its dependencies. That -# way, this list can be easily included in unit test builds that link to mct, -# but excluded from builds that do not include mct. -list(APPEND share_mct_sources - mct_mod.F90 - shr_mct_mod.F90 shr_mpi_mod.F90 - shr_pcdf_mod.F90) + shr_pio_mod.F90 + shr_wv_sat_mod.F90) -# Build a separate list containing the pio wrapper and its dependencies. That -# way, this list can be easily included in unit test builds that include PIO or -# a stub of PIO, but excluded from builds that do not include PIO. -list(APPEND share_pio_sources - shr_pio_mod.F90) +sourcelist_to_parent(share_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) +if (DEFINED ENV{ESMF_ROOT}) + list(APPEND CMAKE_MODULE_PATH $ENV{ESMF_ROOT}/cmake) +endif() +message("ESMF cmake is ${CMAKE_MODULE_PATH}") +find_package(ESMF REQUIRED) +set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS}") diff --git a/test/unit/shr_cal_test/CMakeLists.txt b/test/unit/shr_cal_test/CMakeLists.txt index cdff7072..4cd5c571 100644 --- a/test/unit/shr_cal_test/CMakeLists.txt +++ b/test/unit/shr_cal_test/CMakeLists.txt @@ -33,3 +33,6 @@ add_pfunit_ctest(shr_cal_mod OTHER_SOURCES "${test_sources}") declare_generated_dependencies(shr_cal_mod "${share_genf90_sources}") +#set_target_properties(shr_cal_mod PROPERTIES LINK_FLAGS "${ESMF_F90ESMFLINKLIBS}") + +target_link_libraries(shr_cal_mod esmf pioc netcdff netcdf)