From 3350111f04d2c8447c88f6d5915b915f32364dce Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 6 May 2021 16:25:55 -0400 Subject: [PATCH 01/54] mpp_domain memory leak cleanup This patch fixes some minor memory leaks related to mpp_domains. The following fields have been added to `mpp_deallocate_domain`: * domain%tileList * domain%tile_id_all * domain%check_[CEN] * domain%bound_[CEN] * domain%update_[CEN] as well as the `overlap_type` field * overlap%index I was unsure if `tileList` and `tile_id_all` were always or conditionally allocated, so they are wrapped in `associated()` checks. But this may be redundant. --- mpp/include/mpp_domains_define.inc | 64 +++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 10 deletions(-) diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc index 2d4d7035ea..b7e9ebe3f6 100644 --- a/mpp/include/mpp_domains_define.inc +++ b/mpp/include/mpp_domains_define.inc @@ -7611,6 +7611,10 @@ do i = 1, ntileMe enddo deallocate(domain%x, domain%y, domain%tile_id) +! TODO: Check if these are always allocated +if(ASSOCIATED(domain%tileList)) deallocate(domain%tileList) +if(ASSOCIATED(domain%tile_id_all)) deallocate(domain%tile_id_all) + if(ASSOCIATED(domain%list)) then do i = 0, size(domain%list(:))-1 deallocate(domain%list(i)%x, domain%list(i)%y, domain%list(i)%tile_id) @@ -7618,16 +7622,55 @@ if(ASSOCIATED(domain%list)) then deallocate(domain%list) endif -if(ASSOCIATED(domain%check_C)) call deallocate_overlapSpec(domain%check_C) -if(ASSOCIATED(domain%check_E)) call deallocate_overlapSpec(domain%check_E) -if(ASSOCIATED(domain%check_N)) call deallocate_overlapSpec(domain%check_N) -if(ASSOCIATED(domain%bound_C)) call deallocate_overlapSpec(domain%bound_C) -if(ASSOCIATED(domain%bound_E)) call deallocate_overlapSpec(domain%bound_E) -if(ASSOCIATED(domain%bound_N)) call deallocate_overlapSpec(domain%bound_N) -if(ASSOCIATED(domain%update_T)) call deallocate_overlapSpec(domain%update_T) -if(ASSOCIATED(domain%update_E)) call deallocate_overlapSpec(domain%update_E) -if(ASSOCIATED(domain%update_C)) call deallocate_overlapSpec(domain%update_C) -if(ASSOCIATED(domain%update_N)) call deallocate_overlapSpec(domain%update_N) +if(ASSOCIATED(domain%check_C)) then + call deallocate_overlapSpec(domain%check_C) + deallocate(domain%check_C) +endif + +if(ASSOCIATED(domain%check_E)) then + call deallocate_overlapSpec(domain%check_E) + deallocate(domain%check_E) +endif + +if(ASSOCIATED(domain%check_N)) then + call deallocate_overlapSpec(domain%check_N) + deallocate(domain%check_N) +endif + +if(ASSOCIATED(domain%bound_C)) then + call deallocate_overlapSpec(domain%bound_C) + deallocate(domain%bound_C) +endif + +if(ASSOCIATED(domain%bound_E)) then + call deallocate_overlapSpec(domain%bound_E) + deallocate(domain%bound_E) +endif + +if(ASSOCIATED(domain%bound_N)) then + call deallocate_overlapSpec(domain%bound_N) + deallocate(domain%bound_N) +endif + +if(ASSOCIATED(domain%update_T)) then + call deallocate_overlapSpec(domain%update_T) + deallocate(domain%update_T) +endif + +if(ASSOCIATED(domain%update_E)) then + call deallocate_overlapSpec(domain%update_E) + deallocate(domain%update_E) +endif + +if(ASSOCIATED(domain%update_C)) then + call deallocate_overlapSpec(domain%update_C) + deallocate(domain%update_C) +endif + +if(ASSOCIATED(domain%update_N)) then + call deallocate_overlapSpec(domain%update_N) + deallocate(domain%update_N) +endif end subroutine deallocate_domain2D_local @@ -7871,6 +7914,7 @@ subroutine deallocate_overlap_type( overlap) if(ASSOCIATED(overlap%js)) deallocate(overlap%js) if(ASSOCIATED(overlap%je)) deallocate(overlap%je) if(ASSOCIATED(overlap%dir)) deallocate(overlap%dir) + if(ASSOCIATED(overlap%index)) deallocate(overlap%index) if(ASSOCIATED(overlap%rotation)) deallocate(overlap%rotation) if(ASSOCIATED(overlap%from_contact)) deallocate(overlap%from_contact) if(ASSOCIATED(overlap%msgsize)) deallocate(overlap%msgsize) From b8051486629b7cb99b5deeef75cc7c1ed3a12fad Mon Sep 17 00:00:00 2001 From: Thomas Robinson Date: Fri, 23 Jul 2021 08:32:38 -0400 Subject: [PATCH 02/54] Adds an action to run make check on main branch when alpha and beta tags are pushed. Build is done with intel18 on parallel works azure cloud cluster --- .../workflows/build_parallelWorks_intel_tag.yml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 .github/workflows/build_parallelWorks_intel_tag.yml diff --git a/.github/workflows/build_parallelWorks_intel_tag.yml b/.github/workflows/build_parallelWorks_intel_tag.yml new file mode 100644 index 0000000000..91d1fbd3a9 --- /dev/null +++ b/.github/workflows/build_parallelWorks_intel_tag.yml @@ -0,0 +1,15 @@ +name: Build testing libFMS with intel + +on: + push: + tags: + - '*alpha*' + - '*beta*' +jobs: + intelBuild: + runs-on: [self-hosted, pw-platform] + steps: + - name: Spinning up cluster + run: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/FMStestStartClusters.py azcluster_noaa + - name: Turn off cluster + run: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/stopClusters.py azcluster_noaa From 3535b0780d5f614b495ba594ba3d7a0c5a801ae5 Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Fri, 23 Jul 2021 09:44:03 -0400 Subject: [PATCH 03/54] Modified get/set_date_gregorian tests (#749) Updates time manager testing scripts for testing old and new set/get_date_gregorian routines --- test_fms/time_manager/test_time_manager.F90 | 212 ++++++++++++++++++-- time_manager/time_manager.F90 | 27 +-- 2 files changed, 205 insertions(+), 34 deletions(-) diff --git a/test_fms/time_manager/test_time_manager.F90 b/test_fms/time_manager/test_time_manager.F90 index b176b84938..8957a02f3c 100644 --- a/test_fms/time_manager/test_time_manager.F90 +++ b/test_fms/time_manager/test_time_manager.F90 @@ -49,9 +49,14 @@ program test_time_manager character(len=8) :: test_name character(len=256) :: out_msg -logical :: test1 =.true.,test2 =.true.,test3 =.true.,test4 =.true.,test5 =.true.,test6 =.true.,test7 =.true.,test8 =.true. -logical :: test9 =.true.,test10=.true.,test11=.true.,test12=.true.,test13=.true.,test14=.true.,test15=.true.,test16=.true. -logical :: test17=.true.,test18=.true.,test19=.true.,test20=.true. + !: for testing set/get_date_gregorian + integer, parameter :: days_in_400_year_period = 146097 + integer, dimension(days_in_400_year_period) :: coded_date + integer, dimension(400,12,31) :: date_to_day + + logical :: test1 =.true.,test2 =.true.,test3 =.true.,test4 =.true.,test5 =.true.,test6 =.true.,test7 =.true.,test8 =.true. + logical :: test9 =.true.,test10=.true.,test11=.true.,test12=.true.,test13=.true.,test14=.true.,test15=.true.,test16=.true. + logical :: test17=.true.,test18=.true.,test19=.true.,test20=.true. namelist / test_nml / test1 ,test2 ,test3 ,test4 ,test5 ,test6 ,test7 ,test8, & test9 ,test10,test11,test12,test13,test14,test15,test16, & @@ -608,12 +613,19 @@ program test_time_manager write(outunit,'(a,i6)') ' ticks_per_second=',get_ticks_per_second() !============================================================================================== - ! Tests the new set/get_date_gregorian by comparing against the old set/get_date_gregorian invoked with old_method=.true. + ! Tests the new set/get_date_gregorian by comparing against the old set/get_date_gregorian copied over to this test program ! This test loops through every day up to year 3200 if(test20) then write(outunit,'(/,a)') '################################# test20 #################################' + write(outunit,'(/,a)') ' =====================================================' + write(outunit,'(a)') ' Test get/set_date_gregorian with get/set_date_gregorian_old' + write(outunit,'(a,/)') ' =====================================================' call set_calendar_type(GREGORIAN) + call get_coded_date( coded_date, date_to_day ) ! assign coded_date and date_to_day used by get/set_date_gregorian_old + + ! Check that the get/set_date_gregorian_old here are the same as in time_manager + ! This part of the test will be deleted when the old methods are removed from time_manager do year=1, 3200 leap = mod(year,4) == 0 leap = leap .and. .not.mod(year,100) == 0 @@ -622,50 +634,208 @@ program test_time_manager days_this_month = days_per_month(month) if(leap .and. month == 2) days_this_month = 29 do dday=1,days_this_month - !: test new set_date_gregorian - Time = set_date(year, month, dday, 0, 0, 0) - Time0 = set_date(year, month, dday, 0, 0, 0, old_method=.true.) - if( .not.(Time == Time0) ) call mpp_error(FATAl,'Error testing set_date_gregorian: Time != Time0') + ! test set_date_gregorian + Time = set_date(year, month, dday, 0, 0, 0, old_method=.true.) + Time0 = set_date_gregorian_old(year, month, dday, 0, 0, 0, 0, date_to_day) + if( .not. (Time==Time0) ) then + write(outunit,'("ERROR with year",i5,"mo",i5,"dday",i5)') year, month, dday + call mpp_error(FATAL, 'ERROR testing set_date_gregorian_old: Time!=Time0') + end if + ! test #1 get_date + call get_date(Time0, yr, mo, day, hr, min, sec, old_method=.true.) + call get_date_gregorian_old(Time0, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) + if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then + write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr + write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo + write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day + call mpp_error(FATAl,'Error testing get_date_gregorian_old 1') + end if + ! test #2 get_date call get_date(Time, yr, mo, day, hr, min, sec, old_method=.true.) - call get_date(Time0, yr0, mo0, day0, hr0, min0, sec0, old_method=.true.) + call get_date_gregorian_old(Time, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) + if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then + write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr + write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo + write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day + call mpp_error(FATAl,'Error testing get_date_gregorian 2') + end if + ! test #3 get_date + call get_date(Time, yr, mo, day, hr, min, sec, old_method=.true.) + call get_date_gregorian_old(Time0, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) + if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then + write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr + write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo + write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day + call mpp_error(FATAl,'Error testing get_date_gregorian 3') + end if + ! test #4 get_date + call get_date(Time0, yr, mo, day, hr, min, sec, old_method=.true.) + call get_date_gregorian_old(Time, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day - call mpp_error(FATAl,'Error testing set_date_gregorian') + call mpp_error(FATAl,'Error testing get_date_gregorian 4') + end if + enddo + enddo + enddo + write(outunit,'(a)') 'set_date_gregorian_old and get_date_gregorian_old tests successful' + + ! test the new Gregorian methods and compare with the old methods + do year=1, 3200 + leap = mod(year,4) == 0 + leap = leap .and. .not.mod(year,100) == 0 + leap = leap .or. mod(year,400) == 0 + do month=1,12 + days_this_month = days_per_month(month) + if(leap .and. month == 2) days_this_month = 29 + do dday=1,days_this_month + ! test new set_date_gregorian + Time = set_date(year, month, dday, 0, 0, 0) + Time0 = set_date_gregorian_old(year, month, dday, 0, 0, 0, 0, date_to_day) + if( .not. (Time==Time0) ) then + write(outunit,'("ERROR with year",i5,"mo",i5,"dday",i5)') year, month, dday + call mpp_error(FATAL, 'ERROR testing set_date_gregorian: Time!=Time0') end if - ! test new get_date_gregorian + ! test #1 get_date call get_date(Time0, yr, mo, day, hr, min, sec) - call get_date(Time0, yr0, mo0, day0, hr0, min0, sec0, old_method=.true.) + call get_date_gregorian_old(Time0, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day call mpp_error(FATAl,'Error testing get_date_gregorian 1') end if + ! test #2 get_date call get_date(Time, yr, mo, day, hr, min, sec) - call get_date(Time, yr0, mo0, day0, hr0, min0, sec0, old_method=.true.) + call get_date_gregorian_old(Time, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day - call mpp_error(FATAl,'Error testing set_date_gregorian 2') + call mpp_error(FATAl,'Error testing get_date_gregorian 2') end if + ! test #3 get_date call get_date(Time, yr, mo, day, hr, min, sec) - call get_date(Time0, yr0, mo0, day0, hr0, min0, sec0, old_method=.true.) + call get_date_gregorian_old(Time0, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day - call mpp_error(FATAl,'Error testing set_date_gregorian 2') + call mpp_error(FATAl,'Error testing get_date_gregorian 3') + end if + ! test #4 get_date + call get_date(Time0, yr, mo, day, hr, min, sec) + call get_date_gregorian_old(Time, coded_date, yr0, mo0, day0, hr0, min0, sec0, ticks0) + if( yr0.ne.yr .or. mo0.ne.mo .or. day0.ne.day ) then + write(outunit,"('expected year ',i5,'but got year ',i5)") yr0, yr + write(outunit,"('expected month',i5,'but got month',i5)") mo0, mo + write(outunit,"('expected day ',i5,'but got day ',i5)") day0, day + call mpp_error(FATAl,'Error testing get_date_gregorian 4') end if enddo enddo enddo - write(outunit,'(a)') 'test successful' - endif + write(outunit,'(a)') 'set_date_gregorian and get_date_gregorian tests successful' + endif + + call fms_io_exit + call fms_end + +contains + + ! get_coded_date: copied from subroutine set_calendar_type in time_manager and slightly modified + ! to work in this test program. + subroutine get_coded_date(coded_date_old, date_to_day_old) + + implicit none + + integer, intent(out), dimension(146097) :: coded_date_old + integer, intent(out), dimension(400,12,31) :: date_to_day_old + + integer :: iday, days_this_month, year, month, day + logical :: leap + + iday = 0 + date_to_day = -1 ! invalid_date = -1 in time_manager + do year=1,400 + leap = mod(year,4) == 0 + leap = leap .and. .not.mod(year,100) == 0 + leap = leap .or. mod(year,400) == 0 + do month=1,12 + days_this_month = days_per_month(month) + if(leap .and. month ==2) days_this_month = 29 + do day=1,days_this_month + date_to_day_old(year,month,day) = iday + iday = iday+1 + coded_date_old(iday) = day + 32*(month + 16*year) + enddo ! do day + enddo ! do month + enddo ! do year + + end subroutine get_coded_date + + ! get_date_gregorian_old: original get_date_gregorian subroutine in time_manager that has been slightly + ! modified to work in this test program + subroutine get_date_gregorian_old(time, coded_date, year, month, day, hour, minute, second, tick) + + use time_manager_mod, only : set_time + + integer, parameter :: days_in_400_year_period = 146097 + + type(time_type), intent(in) :: time + integer, intent(in), dimension(days_in_400_year_period) :: coded_date + integer, intent(out) :: year, month, day, hour, minute, second + integer, intent(out) :: tick + + integer :: iday, isec, time_days, time_seconds, time_ticks + + ! set time_days=Time%days and time_seconds=Time%seconds, time_ticks=Time%ticks + call get_time(Time, seconds=time_seconds, days=time_days, ticks=time_ticks) + + iday = mod(time_days+1, days_in_400_year_period) + if(iday == 0) iday = days_in_400_year_period + + year = coded_date(iday)/512 + day = mod(coded_date(iday),32) + month = coded_date(iday)/32 - 16*year + + year = year + 400*(time_days/days_in_400_year_period) + + hour = time_seconds / 3600 + isec = time_seconds - 3600*hour + minute = isec / 60 + second = isec - 60*minute + tick = time_ticks + + end subroutine get_date_gregorian_old + + ! set_date_gregorian_old: original set_date_gregorian function in time_manager that has been slightly + ! modified to work in this test program + function set_date_gregorian_old(year, month, day, hour, minute, second, tick, date_to_day) + + use time_manager_mod, only: set_time + + type(time_type) :: set_date_gregorian_old + + integer, parameter :: days_in_400_year_period = 146097 + + integer, intent(in) :: year, month, day, hour, minute, second, tick + integer, intent(in), dimension(400,12,31) :: date_to_day + + integer :: yr1, day1, second1 + + second1 = second + 60*(minute + 60*hour) + + yr1 = mod(year,400) + if(yr1 == 0) yr1 = 400 + day1 = date_to_day(yr1,month,day) + + day1 = day1 + days_in_400_year_period*((year-1)/400) + + set_date_gregorian_old = set_time(seconds=second1, days=day1, ticks=tick) - call fms_io_exit - call fms_end + end function set_date_gregorian_old - end program test_time_manager +end program test_time_manager diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90 index 83efd88f09..2a9599260a 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -154,10 +154,10 @@ module time_manager_mod ! Define number of days per month integer, private :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) integer, parameter :: seconds_per_day = rseconds_per_day ! This should automatically cast real to integer -integer, parameter :: days_in_400_year_period = 146097 ! Used only for gregorian -integer, dimension(days_in_400_year_period) :: coded_date ! Used only for gregorian -integer, dimension(400,12,31) :: date_to_day ! Used only for gregorian -integer, parameter :: invalid_date=-1 ! Used only for gregorian +integer, parameter :: days_in_400_year_period = 146097 !< Used only for gregorian +integer, dimension(days_in_400_year_period) :: coded_date !< Used only for gregorian, to be removed soon +integer, dimension(400,12,31) :: date_to_day !< Used only for gregorian, to be removed soon +integer, parameter :: invalid_date=-1 !< Used only for gregorian, to be removed soon integer,parameter :: do_floor = 0 integer,parameter :: do_nearest = 1 @@ -1492,6 +1492,7 @@ subroutine set_calendar_type(type, err_msg) calendar_type = type +! this part is to be removed soon with set/get_date_gregorian if(type == GREGORIAN) then date_to_day = invalid_date iday = 0 @@ -1629,10 +1630,10 @@ subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg, logical, intent(in), optional :: old_method !< option to choose betw the new and old ver of get_date_gregorian subroutine. !! When .true., call get_date_gregorian_old to retrieve the date !! from the array coded_date. When .false., call get_date_gregorian to - !! compute the date on the fly. + !! compute the date on the fly. Will be removed with set/get_date_gregorian_old character(len=128) :: err_msg_local integer :: tick1 - logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. + logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. Will be removed if(.not.module_is_initialized) call time_manager_init if(present(err_msg)) err_msg = '' @@ -1755,7 +1756,7 @@ end subroutine get_date_gregorian !> @brief Gets the date on a Gregorian calendar. This is the original/old subroutine. !! Looks up the year, month, day from the coded_date array -!! This subroutine is kept in order to test the new get_date_gregorian +!! This subroutine will be removed soon subroutine get_date_gregorian_old(time, year, month, day, hour, minute, second, tick) ! Computes date corresponding to time for gregorian calendar @@ -2008,8 +2009,8 @@ function set_date_private(year, month, day, hour, minute, second, tick, Time_out logical, intent(in), optional ::old_method !< option to choose betw the new and old ver of get_date_gregorian subroutine. !! When .true., call set_date_gregorian_old to retrieve the time%days !! from the array date_to_day. When .false., call set_date_gregorian to - !! compute the time%days on the fly. - logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. + !! compute the time%days on the fly. This option will be removed with get/set_date_gregorian_old + logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. Will be removed if(.not.module_is_initialized) call time_manager_init @@ -2053,11 +2054,11 @@ function set_date_i(year, month, day, hour, minute, second, tick, err_msg, old_m logical, intent(in), optional :: old_method !< option to choose betw the new and old ver of get_date_gregorian subroutine. !! When .true., call set_date_gregorian_old to retrieve the time%days !! from the array date_to_day. When .false., call set_date_gregorian to - !! compute the time%days on the fly. + !! compute the time%days on the fly. This ption will be removed with get/set_date_gregorian_old character(len=*), intent(out), optional :: err_msg integer :: osecond, ominute, ohour, otick character(len=128) :: err_msg_local - logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. + logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. Will be removed if(.not.module_is_initialized) call time_manager_init if(present(err_msg)) err_msg = '' @@ -2109,7 +2110,7 @@ function set_date_c(string, zero_year_warning, err_msg, allow_rounding, old_meth logical, intent(in), optional :: old_method !< option to choose betw the new and old ver of set_date_gregorian. !! When .true., call set_date_gregorian_old to retrieve the days !! from the array date_to_day. When .false., call set_date_gregorian to - !! compute the days on the fly. + !! compute the days on the fly. Will be removed with set/get_date_gregorian_old character(len=4) :: formt='(i )' logical :: correct_form, zero_year_warning_local, allow_rounding_local logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present. @@ -2296,7 +2297,7 @@ end function set_date_gregorian !> @brief Sets Time_out%days on a Gregorian calendar. This is the original/old subroutine. !! Look up the total number of days between 1/1/0001 to the current month/day/year in the array date_to_day -!! This function is kept in order to test the new set_date_gregorian +!! This function will be removed soon. function set_date_gregorian_old(year, month, day, hour, minute, second, tick, Time_out, err_msg) logical :: set_date_gregorian_old From 1477fb1c466119b5af4a5cbac19f0abe81c436f4 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 23 Jul 2021 09:45:26 -0400 Subject: [PATCH 04/54] Removes the use_mpp_io code in interpolator and amip_interp :'( (#759) --- amip_interp/amip_interp.F90 | 108 +--- interpolator/interpolator.F90 | 1081 +-------------------------------- 2 files changed, 35 insertions(+), 1154 deletions(-) diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index 62a531595b..219c7d16a2 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -94,11 +94,6 @@ module amip_interp_mod use mpp_mod, only: input_nml_file use fms2_io_mod, only: FmsNetcdfFile_t, fms2_io_file_exists=>file_exists, open_file, close_file, & get_dimension_size, fms2_io_read_data=>read_data -!! These are fms_io specific: -use fms_io_mod, only: mpp_io_read_data=>read_data, field_size -use mpp_io_mod, only : mpp_open, mpp_read, MPP_RDONLY, MPP_NETCDF, & - MPP_MULTI, MPP_SINGLE, mpp_close, mpp_get_times -use fms_mod, only: fms_io_file_exists=>file_exist implicit none private @@ -533,15 +528,7 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) call horiz_interp_new ( Interp%Hintrp2, lon_bnd, lat_bnd, & lon_model, lat_model, interp_method="bilinear" ) - if (use_mpp_io) then - !! USE_MPP_IO_WARNING - call mpp_error ('amip_interp_mod', & - 'MPP_IO is no longer supported. Please remove from namelist',& - WARNING) - the_file_exists = fms_io_file_exists(ncfilename) - else - the_file_exists = fms2_io_file_exists(ncfilename) - endif !if (use_mpp_io) + the_file_exists = fms2_io_file_exists(ncfilename) if ( (.NOT. the_file_exists) ) then call mpp_error ('amip_interp_mod', & @@ -550,17 +537,6 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & 'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE) - if (use_mpp_io) then - call field_size(ncfilename, 'TIME', siz) - nrecords = siz (1) - if (nrecords < 1) call mpp_error('amip_interp_mod', & - 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) - allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) - - call mpp_open( unit, ncfilename, MPP_RDONLY, MPP_NETCDF, MPP_MULTI, MPP_SINGLE ) - call mpp_get_times(unit, timeval) - call mpp_close(unit) - else if(.not. open_file(fileobj, trim(ncfilename), 'read')) & call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL) @@ -569,7 +545,6 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) call fms2_io_read_data(fileobj, 'TIME', timeval) - endif !if (use_mpp_io) !!! DEBUG CODE if(DEBUG) then if (mpp_pe() == 0) then @@ -607,12 +582,8 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) if ( .not. allocated(tempamip) ) allocate (tempamip(mobs_sst,nobs_sst)) if (the_file_exists) then - if (use_mpp_io) then - call mpp_io_read_data(ncfilename, 'SST', tempamip, timelevel=k, no_domain=.true.) - else - call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) - call close_file(fileobj) - endif !if (use_mpp_io) + call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) + call close_file(fileobj) tempamip = tempamip + TFREEZE !!! DEBUG CODE @@ -910,6 +881,12 @@ subroutine amip_interp_init() write (unit,nml=amip_interp_nml) endif + if (use_mpp_io) then + !! USE_MPP_IO_WARNING + call mpp_error ('amip_interp_mod', & + 'MPP_IO is no longer supported. Please remove use_mpp_io from amip_interp_nml',& + FATAL) + endif if ( .not. use_ncep_sst ) interp_oi_sst = .false. ! ---- freezing point of sea water in deg K --- @@ -1005,30 +982,19 @@ subroutine amip_interp_init() file_name_sst = trim(file_name_sst)//'.nc' file_name_ice = trim(file_name_ice)//'.nc' - if (use_mpp_io) then - if (.not. fms_io_file_exists(trim(file_name_sst)) ) then - call error_mesg ('amip_interp_init', & - 'file '//trim(file_name_sst)//' does not exist', FATAL) - endif - if (.not. fms_io_file_exists(trim(file_name_ice)) ) then - call error_mesg ('amip_interp_init', & - 'file '//trim(file_name_ice)//' does not exist', FATAL) - endif - else - if (.not. fms2_io_file_exists(trim(file_name_sst)) ) then - call error_mesg ('amip_interp_init', & - 'file '//trim(file_name_sst)//' does not exist', FATAL) - endif - if (.not. fms2_io_file_exists(trim(file_name_ice)) ) then - call error_mesg ('amip_interp_init', & - 'file '//trim(file_name_ice)//' does not exist', FATAL) - endif + if (.not. fms2_io_file_exists(trim(file_name_sst)) ) then + call error_mesg ('amip_interp_init', & + 'file '//trim(file_name_sst)//' does not exist', FATAL) + endif + if (.not. fms2_io_file_exists(trim(file_name_ice)) ) then + call error_mesg ('amip_interp_init', & + 'file '//trim(file_name_ice)//' does not exist', FATAL) + endif - if (.not. open_file(fileobj_sst, trim(file_name_sst), 'read')) & - call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_sst), FATAL) - if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) & - call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL) - endif !if (use_mpp_io) + if (.not. open_file(fileobj_sst, trim(file_name_sst), 'read')) & + call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_sst), FATAL) + if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) & + call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL) module_is_initialized = .true. end subroutine amip_interp_init @@ -1326,10 +1292,10 @@ subroutine read_record (type, Date, Adate, dat) ncfieldname = 'sst' if(type(1:3) == 'sst') then ncfilename = trim(file_name_sst) - if (.not. use_mpp_io) fileobj => fileobj_sst + fileobj => fileobj_sst else if(type(1:3) == 'ice') then ncfilename = trim(file_name_ice) - if (.not. use_mpp_io) fileobj => fileobj_ice + fileobj => fileobj_ice if (lowercase(trim(data_set)) == 'amip2' .or. & lowercase(trim(data_set)) == 'hurrell' .or. & lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC @@ -1344,15 +1310,6 @@ subroutine read_record (type, Date, Adate, dat) if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & 'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE) - if (use_mpp_io) then - call mpp_io_read_data (ncfilename, 'nrecords', nrecords, no_domain=.true.) - if (nrecords < 1) call mpp_error('amip_interp_mod', & - 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) - allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords)) - call mpp_io_read_data(ncfilename, 'yr', ryr, no_domain=.true.) - call mpp_io_read_data(ncfilename, 'mo', rmo, no_domain=.true.) - call mpp_io_read_data(ncfilename, 'dy', rdy, no_domain=.true.) - else call fms2_io_read_data (fileobj, 'nrecords', nrecords) if (nrecords < 1) call mpp_error('amip_interp_mod', & 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) @@ -1360,7 +1317,6 @@ subroutine read_record (type, Date, Adate, dat) call fms2_io_read_data(fileobj, 'yr', ryr) call fms2_io_read_data(fileobj, 'mo', rmo) call fms2_io_read_data(fileobj, 'dy', rdy) - endif !if (use_mpp_io) ierr = 1 do k = 1, nrecords @@ -1393,11 +1349,7 @@ subroutine read_record (type, Date, Adate, dat) !---- read NETCDF data ---- if ( interp_oi_sst ) then - if (use_mpp_io) then - call mpp_io_read_data(ncfilename, ncfieldname, tmp_dat, timelevel=k, no_domain=.true.) - else - call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) - endif !if (use_mpp_io) + call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) ! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation) if ( mobs/=360 .or. nobs/=180 ) then call a2a_bilinear(360, 180, tmp_dat, mobs, nobs, dat) @@ -1405,17 +1357,9 @@ subroutine read_record (type, Date, Adate, dat) dat(:,:) = tmp_dat(:,:) endif else - if (use_mpp_io) then - call mpp_io_read_data(ncfilename, ncfieldname, dat, timelevel=k, no_domain=.true.) - else - call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) - endif !if (use_mpp_io) + call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) endif - if (use_mpp_io) then - idat = nint(dat*100.) ! reconstruct packed data for reproducibility - else - idat = nint(dat) ! reconstruct packed data for reproducibility - endif !(use_mpp_io) + idat = nint(dat) ! reconstruct packed data for reproducibility !---- unpacking of data ---- diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index 4ae126491b..f6292b502d 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -35,23 +35,6 @@ module interpolator_mod WARNING, & NOTE, & input_nml_file -use mpp_io_mod, only : mpp_open, & - mpp_close, & - mpp_get_times, & - mpp_get_atts, & - mpp_get_info, & - mpp_read, & - mpp_get_axes, & - mpp_get_axis_data, & - mpp_get_fields, & - fieldtype, & - atttype, & - axistype, & - MPP_RDONLY, & - MPP_NETCDF, & - MPP_MULTI, & - MPP_APPEND, & - MPP_SINGLE use mpp_domains_mod, only : mpp_domains_init, & mpp_update_domains, & mpp_define_domains, & @@ -66,7 +49,6 @@ module interpolator_mod fms_init, & mpp_root_pe, stdlog, & check_nml_error -use fms_mod, only : fms_io_file_exist => file_exist use fms2_io_mod, only : FmsNetcdfFile_t, fms2_io_file_exist => file_exists, dimension_exists, & open_file, fms2_io_read_data=>read_data, & variable_exists, get_variable_num_dimensions, & @@ -260,10 +242,6 @@ module interpolator_mod integer :: itaum !< No description integer :: itaup !< No description -!< These are fms_io specific -integer :: unit !< Unit number on which file is being read. -type(fieldtype), pointer :: field_type(:) =>NULL() !< NetCDF field type - end type interpolate_type !> @addtogroup interpolator_mod @@ -283,12 +261,6 @@ module interpolator_mod integer :: nlevh !< No description integer :: len, ntime_in, num_fields !< No description -!< These are fms_io specific -integer :: natt !< No description -type(axistype), allocatable :: axes(:) !< No description -type(axistype),save :: time_axis !< No description -type(fieldtype), allocatable :: varfields(:) !< No description - ! pletzer real, allocatable :: time_in(:) ! sjs real, allocatable :: climdata(:,:,:), climdata2(:,:,:) @@ -401,10 +373,6 @@ subroutine interpolate_type_eq (Out, In) Out%itaum = In%itaum Out%itaup = In%itaup - !< These are fms_io specific - if(associated(Out%field_type)) Out%field_type => In%field_type - Out%unit = In%unit - end subroutine interpolate_type_eq @@ -485,18 +453,14 @@ subroutine interpolator_init( clim_type, file_name, lonb_mod, latb_mod, & module_is_initialized = .true. endif !> if (module_is_initilized) - if (use_mpp_io) then - call mpp_error(WARNING, "Interpolator::nml=interpolator_nml " //& - 'MPP_IO is no longer supported. Please remove from namelist') - call mppio_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, & - data_names, data_out_of_bounds, & - vert_interp, clim_units, single_year_file) -else - call fms2io_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, & + call mpp_error(FATAL, "Interpolator::nml=interpolator_nml " //& + 'MPP_IO is no longer supported. Please remove from use_mpp_io from interpolator_nml') +endif + +call fms2io_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, & data_names, data_out_of_bounds, & vert_interp, clim_units, single_year_file) -endif end subroutine interpolator_init @@ -1646,24 +1610,7 @@ subroutine obtain_interpolator_time_slices (clim_type, Time) clim_type%indexm(:) = indexm clim_type%indexp(:) = indexp clim_type%climatology(:) = climatology - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_pyear(:,:,:,i), & - clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_pyear(:,:,:,i), & - clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_nyear(:,:,:,i), & - clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_nyear(:,:,:,i), & - clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - end do - else - do i=1, size(clim_type%field_name(:)) + do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), & clim_type%pmon_pyear(:,:,:,i), & clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) @@ -1677,29 +1624,12 @@ subroutine obtain_interpolator_time_slices (clim_type, Time) call read_data(clim_type,clim_type%field_name(i), & clim_type%nmon_nyear(:,:,:,i), & clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - end do - endif ! if (use_mpp_io) + end do endif else ! We are within a climatology data set - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - if (taum /= clim_type%time_init(i,1) .or. & - taup /= clim_type%time_init(i,2) ) then - - - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_pyear(:,:,:,i), taum,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_pyear(:,:,:,i), taup,i,Time) - clim_type%time_init(i,1) = taum - clim_type%time_init(i,2) = taup - endif - end do - else do i=1, size(clim_type%field_name(:)) if (taum /= clim_type%time_init(i,1) .or. & taup /= clim_type%time_init(i,2) ) then @@ -1714,7 +1644,6 @@ subroutine obtain_interpolator_time_slices (clim_type, Time) clim_type%time_init(i,2) = taup endif end do - endif !(use_mpp_io) ! clim_type%pmon_nyear = 0.0 ! clim_type%nmon_nyear = 0.0 @@ -1748,25 +1677,14 @@ subroutine obtain_interpolator_time_slices (clim_type, Time) !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time) - clim_type%time_init(i,1) = taum - clim_type%itaum = 1 - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time) - clim_type%time_init(i,2) = taup - clim_type%itaup = 2 - end do - else - do i=1, size(clim_type%field_name(:)) + do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 - end do - endif ! if (use_mpp_io) + end do endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then ! Can't think of a situation where we would have the next time level but not the previous. @@ -1777,17 +1695,10 @@ subroutine obtain_interpolator_time_slices (clim_type, Time) !We have the previous time step but not the next time step data clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) - clim_type%time_init(i,clim_type%itaup)=taup - end do - else do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup end do - endif ! if (use_mpp_io) endif @@ -1934,12 +1845,7 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & i = 1 if(present(clim_units)) then - if (use_mpp_io) then - call mpp_get_atts(clim_type%field_type(i),units=clim_units) - clim_units = chomp(clim_units) - else call get_variable_units(clim_type%fileobj, clim_type%field_name(i), clim_units) - endif endif @@ -2066,23 +1972,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & clim_type%indexm(:) = indexm clim_type%indexp(:) = indexp clim_type%climatology(:) = climatology - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_pyear(:,:,:,i), & - clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_pyear(:,:,:,i), & - clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_nyear(:,:,:,i), & - clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_nyear(:,:,:,i), & - clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - end do - else do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), & clim_type%pmon_pyear(:,:,:,i), & @@ -2098,29 +1987,12 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & clim_type%nmon_nyear(:,:,:,i), & clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) end do - endif !if (use_mpp_io) endif else ! We are within a climatology data set - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - if (taum /= clim_type%time_init(i,1) .or. & - taup /= clim_type%time_init(i,2) ) then - - - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_pyear(:,:,:,i), taum,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_pyear(:,:,:,i), taup,i,Time) - clim_type%time_init(i,1) = taum - clim_type%time_init(i,2) = taup - endif - end do - else do i=1, size(clim_type%field_name(:)) if (taum /= clim_type%time_init(i,1) .or. & taup /= clim_type%time_init(i,2) ) then @@ -2135,7 +2007,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & clim_type%time_init(i,2) = taup endif end do - endif ! clim_type%pmon_nyear = 0.0 ! clim_type%nmon_nyear = 0.0 @@ -2169,16 +2040,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time) - clim_type%time_init(i,1) = taum - clim_type%itaum = 1 - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time) - clim_type%time_init(i,2) = taup - clim_type%itaup = 2 - end do - else do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum @@ -2187,7 +2048,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & clim_type%time_init(i,2) = taup clim_type%itaup = 2 end do - endif !if (use_mpp_io) endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then ! Can't think of a situation where we would have the next time level but not the previous. @@ -2198,17 +2058,10 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, & !We have the previous time step but not the next time step data clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 - if (use_mpp_io) then - do i=1, size(clim_type%field_name(:)) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) - clim_type%time_init(i,clim_type%itaup)=taup - end do - else do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup end do - endif !if (use_mpp_io) endif @@ -2574,21 +2427,6 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js clim_type%indexm(i) = indexm clim_type%indexp(i) = indexp clim_type%climatology(i) = climatology - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_pyear(:,:,:,i), & - clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_pyear(:,:,:,i), & - clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_nyear(:,:,:,i), & - clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_nyear(:,:,:,i), & - clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - else call read_data(clim_type,clim_type%field_name(i), & clim_type%pmon_pyear(:,:,:,i), & clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) @@ -2602,7 +2440,6 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js call read_data(clim_type,clim_type%field_name(i), & clim_type%nmon_nyear(:,:,:,i), & clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - endif !if (use_mpp_io) endif @@ -2613,15 +2450,9 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js if (taum /= clim_type%time_init(i,1) .or. & taup /= clim_type%time_init(i,2) ) then - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time) - else call read_data(clim_type,clim_type%field_name(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time) ! Read the data for the next month in the previous climatology. call read_data(clim_type,clim_type%field_name(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time) - endif !if (use_mpp_io) !RSHbug clim_type%pmon_nyear = 0.0 !RSHbug clim_type%nmon_nyear = 0.0 @@ -2662,21 +2493,12 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time) - clim_type%time_init(i,1) = taum - clim_type%itaum = 1 - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time) - clim_type%time_init(i,2) = taup - clim_type%itaup = 2 - else call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 - endif !if (use_mpp_io) endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then ! Can't think of a situation where we would have the next time level but not the previous. @@ -2687,11 +2509,7 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js !We have the previous time step but not the next time step data clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) - else call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) - endif !if (use_mpp_io) clim_type%time_init(i,clim_type%itaup)=taup endif @@ -3054,21 +2872,6 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli clim_type%indexm(i) = indexm clim_type%indexp(i) = indexp clim_type%climatology(i) = climatology - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_pyear(:,:,:,i), & - clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_pyear(:,:,:,i), & - clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%pmon_nyear(:,:,:,i), & - clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time) - call interp_read_data_mppio(clim_type,clim_type%field_type(i), & - clim_type%nmon_nyear(:,:,:,i), & - clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - else call read_data(clim_type,clim_type%field_name(i), & clim_type%pmon_pyear(:,:,:,i), & clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time) @@ -3082,7 +2885,6 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli call read_data(clim_type,clim_type%field_name(i), & clim_type%nmon_nyear(:,:,:,i), & clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time) - endif !if (use_mpp_io) endif @@ -3093,15 +2895,9 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli if (taum /= clim_type%time_init(i,1) .or. & taup /= clim_type%time_init(i,2) ) then - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time) -! Read the data for the next month in the previous climatology. - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time) - else call read_data(clim_type,clim_type%field_name(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time) ! Read the data for the next month in the previous climatology. call read_data(clim_type,clim_type%field_name(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time) - endif !RSHbug clim_type%pmon_nyear = 0.0 !RSHbug clim_type%nmon_nyear = 0.0 @@ -3141,21 +2937,12 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time) - clim_type%time_init(i,1) = taum - clim_type%itaum = 1 - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time) - clim_type%time_init(i,2) = taup - clim_type%itaup = 2 - else call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 - endif !(use_mpp_io) endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then ! Can't think of a situation where we would have the next time level but not the previous. @@ -3166,11 +2953,7 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli !We have the previous time step but not the next time step data clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 - if (use_mpp_io) then - call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) - else call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time) - endif clim_type%time_init(i,clim_type%itaup)=taup endif endif! TIME_FLAG .eq. LINEAR .and. (.not. read_all_on_init) @@ -3645,18 +3428,11 @@ subroutine interpolator_end(clim_type) deallocate(clim_type%nmon_pyear) endif -!< These are fms_io specific -if (associated (clim_type%field_type)) deallocate(clim_type%field_type) - !! RSH mod if( .not. (clim_type%TIME_FLAG .eq. LINEAR .and. & ! read_all_on_init)) .or. clim_type%TIME_FLAG .eq. BILINEAR ) then read_all_on_init) ) then - if (use_mpp_io) then - call mpp_close(clim_type%unit) - else call close_file(clim_type%fileobj) - endif !if (use_mpp_io) endif @@ -4072,845 +3848,6 @@ subroutine interp_linear ( grdin, grdout, datin, datout ) end subroutine interp_linear ! !######################################################################## -subroutine mppio_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, & - data_names, data_out_of_bounds, & - vert_interp, clim_units, single_year_file) - -type(interpolate_type), intent(inout) :: clim_type -character(len=*), intent(in) :: file_name -real , intent(in) :: lonb_mod(:,:), latb_mod(:,:) -character(len=*), intent(in) , optional :: data_names(:) -!++lwh -integer , intent(in) :: data_out_of_bounds(:) -integer , intent(in), optional :: vert_interp(:) -!--lwh -character(len=*), intent(out), optional :: clim_units(:) -logical, intent(out), optional :: single_year_file - -integer :: unit -character(len=64) :: src_file -!++lwh -real :: dlat, dlon -!--lwh -type(time_type) :: base_time -logical :: NAME_PRESENT -real :: dtr,tpi -integer :: fileday, filemon, fileyr, filehr, filemin,filesec, m,m1 -character(len= 20) :: fileunits -real, dimension(:), allocatable :: alpha -integer :: j, i -logical :: non_monthly -character(len=24) :: file_calendar -character(len=256) :: error_mesg -integer :: model_calendar -integer :: yr, mo, dy, hr, mn, sc -integer :: n -type(time_type) :: Julian_time, Noleap_time -real, allocatable :: time_in(:) -real, allocatable, save :: agrid_mod(:,:,:) -integer :: nx, ny - -clim_type%separate_time_vary_calc = .false. - -tpi = 2.0*PI ! 4.*acos(0.) -dtr = tpi/360. - -num_fields = 0 - -!-------------------------------------------------------------------- -! open source file containing fields to be interpolated -!-------------------------------------------------------------------- -src_file = 'INPUT/'//trim(file_name) - -if(fms_io_file_exist(trim(src_file))) then - call mpp_open( unit, trim(src_file), action=MPP_RDONLY, & - form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_SINGLE ) -else -!Climatology file doesn't exist, so exit - call mpp_error(FATAL,'Interpolator_init : Data file '//trim(src_file)//' does not exist') -endif - -!Find the number of variables (nvar) in this file -call mpp_get_info(unit, ndim, nvar, natt, ntime) -clim_type%unit = unit -clim_type%file_name = trim(file_name) - -num_fields = nvar -if(present(data_names)) num_fields= size(data_names(:)) - -! ------------------------------------------------------------------- -! Allocate space for the number of axes in the data file. -! ------------------------------------------------------------------- -allocate(axes(ndim)) -call mpp_get_axes(unit, axes, time_axis) - -nlon=0 ! Number of longitudes (center-points) in the climatology. -nlat=0 ! Number of latitudes (center-points) in the climatology. -nlev=0 ! Number of levels (center-points) in the climatology. -nlatb=0 ! Number of longitudes (boundaries) in the climatology. -nlonb=0 ! Number of latitudes (boundaries) in the climatology. -nlevh=0 ! Number of levels (boundaries) in the climatology. - -clim_type%level_type = 0 ! Default value - -!++lwh -! ------------------------------------------------------------------- -! For 2-D fields, set a default value of nlev=nlevh=1 -! ------------------------------------------------------------------- -nlev = 1 -nlevh = 1 -!--lwh - clim_type%vertical_indices = 0 ! initial value - -do i = 1, ndim - call mpp_get_atts(axes(i), name=name,len=len,units=units, & - calendar=file_calendar, sense=sense) - select case(trim(name)) - case('lat') - nlat=len - allocate(clim_type%lat(nlat)) - call mpp_get_axis_data(axes(i),clim_type%lat) - select case(units(1:6)) - case('degree') - clim_type%lat = clim_type%lat*dtr - case('radian') - case default - call mpp_error(FATAL, "interpolator_init : Units for lat not recognised in file "//file_name) - end select - case('lon') - nlon=len - allocate(clim_type%lon(nlon)) - call mpp_get_axis_data(axes(i),clim_type%lon) - select case(units(1:6)) - case('degree') - clim_type%lon = clim_type%lon*dtr - case('radian') - case default - call mpp_error(FATAL, "interpolator_init : Units for lon not recognised in file "//file_name) - end select - case('latb') - nlatb=len - allocate(clim_type%latb(nlatb)) - call mpp_get_axis_data(axes(i),clim_type%latb) - select case(units(1:6)) - case('degree') - clim_type%latb = clim_type%latb*dtr - case('radian') - case default - call mpp_error(FATAL, "interpolator_init : Units for latb not recognised in file "//file_name) - end select - case('lonb') - nlonb=len - allocate(clim_type%lonb(nlonb)) - call mpp_get_axis_data(axes(i),clim_type%lonb) - select case(units(1:6)) - case('degree') - clim_type%lonb = clim_type%lonb*dtr - case('radian') - case default - call mpp_error(FATAL, "interpolator_init : Units for lonb not recognised in file "//file_name) - end select - case('pfull') - nlev=len - allocate(clim_type%levs(nlev)) - call mpp_get_axis_data(axes(i),clim_type%levs) - clim_type%level_type = PRESSURE - ! Convert to Pa - if( trim(adjustl(lowercase(chomp(units)))) == "mb" .or. trim(adjustl(lowercase(chomp(units)))) == "hpa") then - clim_type%levs = clim_type%levs * 100. - end if -! define the direction of the vertical data axis -! switch index order if necessary so that indx 1 is at lowest pressure, -! index nlev at highest pressure. - if( sense == 1 ) then - clim_type%vertical_indices = INCREASING_UPWARD - allocate (alpha(nlev)) - do n = 1, nlev - alpha(n) = clim_type%levs(nlev-n+1) - end do - do n = 1, nlev - clim_type%levs(n) = alpha(n) - end do - deallocate (alpha) - else - clim_type%vertical_indices = INCREASING_DOWNWARD - endif - - case('phalf') - nlevh=len - allocate(clim_type%halflevs(nlevh)) - call mpp_get_axis_data(axes(i),clim_type%halflevs) - clim_type%level_type = PRESSURE - ! Convert to Pa - if( trim(adjustl(lowercase(chomp(units)))) == "mb" .or. trim(adjustl(lowercase(chomp(units)))) == "hpa") then - clim_type%halflevs = clim_type%halflevs * 100. - end if -! define the direction of the vertical data axis -! switch index order if necessary so that indx 1 is at lowest pressure, -! index nlev at highest pressure. - if( sense == 1 ) then - clim_type%vertical_indices = INCREASING_UPWARD - allocate (alpha(nlevh)) - do n = 1, nlevh - alpha(n) = clim_type%halflevs(nlevh-n+1) - end do - do n = 1, nlevh - clim_type%halflevs(n) = alpha(n) - end do - deallocate (alpha) - else - clim_type%vertical_indices = INCREASING_DOWNWARD - endif - case('sigma_full') - nlev=len - allocate(clim_type%levs(nlev)) - call mpp_get_axis_data(axes(i),clim_type%levs) - clim_type%level_type = SIGMA - case('sigma_half') - nlevh=len - allocate(clim_type%halflevs(nlevh)) - call mpp_get_axis_data(axes(i),clim_type%halflevs) - clim_type%level_type = SIGMA - - case('time') - model_calendar = get_calendar_type() - fileday = 0 - filemon = 0 - fileyr = 0 - filehr = 0 - filemin= 0 - filesec = 0 - select case(units(:3)) - case('day') - fileunits = units(12:) !Assuming "days since YYYY-MM-DD HH:MM:SS" - if ( len_trim(fileunits) < 19 ) then - write(error_mesg, '(A49,A,A49,A)' ) & - 'Interpolator_init : Incorrect time units in file ', & - trim(file_name), '. Expecting days since YYYY-MM-DD HH:MM:SS, found', & - trim(units) - call mpp_error(FATAL,error_mesg) - endif - read(fileunits(1:4) , *) fileyr - read(fileunits(6:7) , *) filemon - read(fileunits(9:10) , *) fileday - read(fileunits(12:13), *) filehr - read(fileunits(15:16), *) filemin - read(fileunits(18:19), *) filesec - case('mon') - fileunits = units(14:) !Assuming "months since YYYY-MM-DD HH:MM:SS" - if ( len_trim(fileunits) < 19 ) then - write(error_mesg, '(A49,A,A51,A)' ) & - 'Interpolator_init : Incorrect time units in file ', & - trim(file_name), '. Expecting months since YYYY-MM-DD HH:MM:SS, found', & - trim(units) - call mpp_error(FATAL,error_mesg) - endif - read(fileunits(1:4) , *) fileyr - read(fileunits(6:7) , *) filemon - read(fileunits(9:10) , *) fileday - read(fileunits(12:13), *) filehr - read(fileunits(15:16), *) filemin - read(fileunits(18:19), *) filesec - case default - call mpp_error(FATAL,'Interpolator_init : Time units not recognised in file '//file_name) - end select - - clim_type%climatological_year = (fileyr == 0) - - if (.not. clim_type%climatological_year) then - -!---------------------------------------------------------------------- -! if file date has a non-zero year in the base time, determine that -! base_time based on the netcdf info. -!---------------------------------------------------------------------- - if ( (model_calendar == JULIAN .and. & - & trim(adjustl(lowercase(file_calendar))) == 'julian') .or. & - & (model_calendar == NOLEAP .and. & - & trim(adjustl(lowercase(file_calendar))) == 'noleap') ) then - call mpp_error (NOTE, 'interpolator[1]_mod: Model and file& - & calendars are the same for file ' // & - & trim(file_name) // '; no calendar conversion & - &needed') - base_time = set_date (fileyr, filemon, fileday, filehr, & - filemin,filesec) - else if ( (model_calendar == JULIAN .and. & - & trim(adjustl(lowercase(file_calendar))) == 'noleap')) then - call mpp_error (NOTE, 'interpolator[1]_mod: Using julian & - &model calendar and noleap file calendar& - & for file ' // trim(file_name) // & - &'; calendar conversion needed') - base_time = set_date_no_leap (fileyr, filemon, fileday, & - & filehr, filemin, filesec) - else if ( (model_calendar == NOLEAP .and. & - & trim(adjustl(lowercase(file_calendar))) == 'julian')) then - call mpp_error (NOTE, 'interpolator[1]_mod: Using noleap & - &model calendar and julian file calendar& - & for file ' // trim(file_name) // & - &'; calendar conversion needed') - base_time = set_date_julian (fileyr, filemon, fileday, & - & filehr, filemin, filesec) - else - call mpp_error (FATAL , 'interpolator[1]_mod: Model and file& - & calendars ( ' // trim(file_calendar) // ' ) differ & - &for file ' // trim(file_name) // '; this calendar & - &conversion not currently available') - endif - else -!! if the year is specified as '0000', then the file is intended to -!! apply to all years -- the time variables within the file refer to -!! the displacement from the start of each year to the time of the -!! associated data. Time interpolation is to be done with interface -!! time_interp_list, with the optional argument modtime=YEAR. base_time -!! is set to an arbitrary value here; it's only use will be as a -!! timestamp for optionally generated diagnostics. - base_time = get_base_time () - endif - ntime_in = 1 - if (ntime > 0) then - allocate(time_in(ntime), clim_type%time_slice(ntime)) - allocate(clim_type%clim_times(12,(ntime+11)/12)) - time_in = 0.0 - clim_type%time_slice = set_time(0,0) + base_time - clim_type%clim_times = set_time(0,0) + base_time - call mpp_get_times(clim_type%unit, time_in) - ntime_in = ntime -! determine whether the data is a continuous set of monthly values or -! a series of annual cycles spread throughout the period of data - non_monthly = .false. - do n = 1, ntime-1 -! Assume that the times in the data file correspond to days only. - if (time_in(n+1) > (time_in(n) + 32.)) then - non_monthly = .true. - exit - endif - end do - if (clim_type%climatological_year) then - call mpp_error (NOTE, 'interpolator[1]_mod :' // & - trim(file_name) // ' is a year-independent climatology file') - else - call mpp_error (NOTE, 'interpolator[1]_mod :' // & - trim(file_name) // ' is a timeseries file') - endif - do n = 1, ntime -!Assume that the times in the data file correspond to days only. - if (clim_type%climatological_year) then -!! RSH NOTE: -!! for this case, do not add base_time. time_slice will be sent to -!! time_interp_list with the optional argument modtime=YEAR, so that -!! the time that is needed in time_slice is the displacement into the -!! year, not the displacement from a base_time. - clim_type%time_slice(n) = & - set_time(INT( ( time_in(n) - INT(time_in(n)) ) * SECONDS_PER_DAY), & - INT(time_in(n))) - else -!-------------------------------------------------------------------- -! if fileyr /= 0 (i.e., climatological_year=F), -! then define the times associated with each time- -! slice. if calendar conversion between data file and model calendar -! is needed, do it so that data from the file is associated with the -! same calendar time in the model. here the time_slice needs to -! include the base_time; values will be generated relative to the -! "real" time. -!-------------------------------------------------------------------- - if ( (model_calendar == JULIAN .and. & - & trim(adjustl(lowercase(file_calendar))) == 'julian') .or. & - & (model_calendar == NOLEAP .and. & - & trim(adjustl(lowercase(file_calendar))) == 'noleap') ) then -!--------------------------------------------------------------------- -! no calendar conversion needed. -!--------------------------------------------------------------------- - clim_type%time_slice(n) = & - set_time(INT( ( time_in(n) - INT(time_in(n)) ) * SECONDS_PER_DAY ),& - INT(time_in(n))) & - + base_time -!--------------------------------------------------------------------- -! convert file times from noleap to julian. -!--------------------------------------------------------------------- - else if ( (model_calendar == JULIAN .and. & - & trim(adjustl(lowercase(file_calendar))) == 'noleap')) then - Noleap_time = set_time (0, INT(time_in(n))) + base_time - call get_date_no_leap (Noleap_time, yr, mo, dy, hr, & - mn, sc) - clim_type%time_slice(n) = set_date_julian (yr, mo, dy, & - hr, mn, sc) - if (n == 1) then - call print_date (clim_type%time_slice(1), & - str= 'for file ' // trim(file_name) // ', the & - &first time slice is mapped to :') - endif - if (n == ntime) then - call print_date (clim_type%time_slice(ntime), & - str= 'for file ' // trim(file_name) // ', the & - &last time slice is mapped to:') - endif -!--------------------------------------------------------------------- -! convert file times from julian to noleap. -!--------------------------------------------------------------------- - else if ( (model_calendar == NOLEAP .and. & - & trim(adjustl(lowercase(file_calendar))) == 'julian')) then - Julian_time = set_time (0, INT(time_in(n))) + base_time - call get_date_julian (Julian_time, yr, mo, dy, hr, mn, sc) - clim_type%time_slice(n) = set_date_no_leap (yr, mo, dy, & - hr, mn, sc) - if (n == 1) then - call print_date (clim_type%time_slice(1), & - str= 'for file ' // trim(file_name) // ', the & - &first time slice is mapped to :') - endif - if (n == ntime) then - call print_date (clim_type%time_slice(ntime), & - str= 'for file ' // trim(file_name) // ', the & - &last time slice is mapped to:') - endif -!--------------------------------------------------------------------- -! any other calendar combinations would have caused a fatal error -! above. -!--------------------------------------------------------------------- - endif - endif - m = (n-1)/12 +1 ; m1 = n- (m-1)*12 - clim_type%clim_times(m1,m) = clim_type%time_slice(n) - enddo - else - allocate(time_in(1), clim_type%time_slice(1)) - allocate(clim_type%clim_times(1,1)) - time_in = 0.0 - clim_type%time_slice = set_time(0,0) + base_time - clim_type%clim_times(1,1) = set_time(0,0) + base_time - endif - deallocate(time_in) - end select ! case(name) -enddo -! ------------------------------------------------------------------- -! For 2-D fields, allocate levs and halflevs here -! code is still needed for case when only halflevs are in data file. -! ------------------------------------------------------------------- - if( .not. associated(clim_type%levs) ) then - allocate( clim_type%levs(nlev) ) - clim_type%levs = 0.0 - endif - if( .not. associated(clim_type%halflevs) ) then - allocate( clim_type%halflevs(nlev+1) ) - clim_type%halflevs(1) = 0.0 - if (clim_type%level_type == PRESSURE) then - clim_type%halflevs(nlev+1) = 1013.25* 100.0 ! MKS - else if (clim_type%level_type == SIGMA ) then - clim_type%halflevs(nlev+1) = 1.0 - endif - do n=2,nlev - clim_type%halflevs(n) = 0.5*(clim_type%levs(n) + & - clim_type%levs(n-1)) - end do - endif -deallocate(axes) -! In the case where only the midpoints of the longitudes are defined we force -! the definition -! of the boundaries to be half-way between the midpoints. -if (.not. associated(clim_type%lon) .and. .not. associated(clim_type%lonb)) & - call mpp_error(FATAL,'Interpolator_init : There appears to be no longitude axis in file '//file_name) -if (.not. associated(clim_type%lonb) ) then - if (size(clim_type%lon(:)) /= 1) then - allocate(clim_type%lonb(size(clim_type%lon(:))+1)) - dlon = (clim_type%lon(2)-clim_type%lon(1))/2.0 - clim_type%lonb(1) = clim_type%lon(1) - dlon - clim_type%lonb(2:) = clim_type%lon(1:) + dlon - else -!! this is the case for zonal mean data, lon = 1, lonb not present -!! in file. - allocate(clim_type%lonb(2)) - clim_type%lonb(1) = -360.*dtr - clim_type%lonb(2) = 360.0*dtr - clim_type%lon(1) = 0.0 - endif -endif -!clim_type%lonb=clim_type%lonb*dtr -! This assumes the lonb are in degrees in the NetCDF file! -if (.not. associated(clim_type%lat) .and. .not. associated(clim_type%latb)) & - call mpp_error(FATAL,'Interpolator_init : There appears to be no latitude axis in file '//file_name) -! In the case where only the grid midpoints of the latitudes are defined we -! force the -! definition of the boundaries to be half-way between the midpoints. -if (.not. associated(clim_type%latb) ) then - allocate(clim_type%latb(nlat+1)) - dlat = (clim_type%lat(2)-clim_type%lat(1)) * 0.5 -! clim_type%latb(1) = min( 90., max(-90., clim_type%lat(1) - dlat) ) - clim_type%latb(1) = min( PI/2., max(-PI/2., clim_type%lat(1) - dlat) ) - clim_type%latb(2:nlat) = ( clim_type%lat(1:nlat-1) + clim_type%lat(2:nlat) )* 0.5 - dlat = ( clim_type%lat(nlat) - clim_type%lat(nlat-1) ) * 0.5 -! clim_type%latb(nlat+1) = min( 90., max(-90., clim_type%lat(nlat) + dlat) ) - clim_type%latb(nlat+1) = min( PI/2., max(-PI/2., clim_type%lat(nlat) + dlat)) -endif -!clim_type%latb=clim_type%latb*dtr -!Assume that the horizontal interpolation within a file is the same for each -!variable. - if (conservative_interp) then - call horiz_interp_new (clim_type%interph, & - clim_type%lonb, clim_type%latb, & - lonb_mod, latb_mod) - else - call mpp_error(NOTE, "Using Bilinear interpolation") - !!! DEBUG CODE - if (.not. allocated(agrid_mod)) then - nx = size(lonb_mod,1)-1 - ny = size(latb_mod,2)-1 - allocate(agrid_mod(nx,ny,2)) - do j=1,ny - do i=1,nx - call cell_center2((/lonb_mod(i,j),latb_mod(i,j)/), & - (/lonb_mod(i+1,j),latb_mod(i+1,j)/), & - (/lonb_mod(i,j+1),latb_mod(i,j+1)/), & - (/lonb_mod(i+1,j+1),latb_mod(i+1,j+1)/), agrid_mod(i,j,:)) - enddo - enddo - endif - !!! END DEBUG CODE - call horiz_interp_new (clim_type%interph, & - clim_type%lonb, clim_type%latb, & - agrid_mod(:,:,1), agrid_mod(:,:,2), interp_method="bilinear") - endif -!-------------------------------------------------------------------- -! allocate the variable clim_type%data . This will be the climatology -! data horizontally interpolated, so it will be on the model horizontal -! grid, but it will still be on the climatology vertical grid. -!-------------------------------------------------------------------- -select case(ntime) - case (13:) -! This may be data that does not have a continous time-line -! i.e. IPCC data where decadal data is present but we wish to retain -! the seasonal nature of the data. -!! RSH: the following test will not always work; instead use the -!! RSH: non-monthly variable to test on. -!RSHlast_time = clim_type%time_slice(1) + ( ntime -1 ) * & -!RSH ( clim_type%time_slice(2) - clim_type%time_slice(1) ) -!RSHif ( last_time < clim_type%time_slice(ntime)) then - if (non_monthly) then -! We have a broken time-line. e.g. We have monthly data but only for years -! ending in 0. 1960,1970 etc. -! allocate(clim_type%data(size(lonb_mod(:))-1, size(latb_mod(:))-1, nlev, 2, -! num_fields)) - allocate(clim_type%pmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) - allocate(clim_type%pmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) - allocate(clim_type%nmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) - allocate(clim_type%nmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) - clim_type%pmon_pyear = 0.0 - clim_type%pmon_nyear = 0.0 - clim_type%nmon_nyear = 0.0 - clim_type%nmon_pyear = 0.0 - clim_type%TIME_FLAG = BILINEAR -else -! We have a continuous time-line so treat as for 5-12 timelevels as below. - if ( .not. read_all_on_init) then - allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) - else - allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & - ntime, num_fields)) - endif - clim_type%data = 0.0 - clim_type%TIME_FLAG = LINEAR -endif -!++lwh - case (1:12) -!--lwh -! We have more than 4 timelevels -! Assume we have monthly or higher time resolution datasets (climatology or time -! series) -! So we only need to read 2 datasets and apply linear temporal interpolation. - if ( .not. read_all_on_init) then - allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) - else - allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & - ntime, num_fields)) - endif - clim_type%data = 0.0 - clim_type%TIME_FLAG = LINEAR -!++lwh -!case (1:4) -! Assume we have seasonal data and read in all the data. -! We can apply sine curves to these data. -! allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, ntime, -! num_fields)) -! clim_type%data = 0.0 -! clim_type%TIME_FLAG = SEASONAL -!--lwh -! case (default) - case(:0) - clim_type%TIME_FLAG = NOTIME - allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields)) -end select -!------------------------------------------------------------------ -! Allocate space for the single time level of the climatology on its -! grid size. -!---------------------------------------------------------------------- - if(clim_type%TIME_FLAG .eq. LINEAR ) then - allocate(clim_type%time_init(num_fields,2)) - else - allocate(clim_type%time_init(num_fields,ntime)) - endif - allocate (clim_type%indexm(num_fields), & - clim_type%indexp(num_fields), & - clim_type%climatology(num_fields)) - clim_type%time_init(:,:) = 0 - clim_type%indexm(:) = 0 - clim_type%indexp(:) = 0 - clim_type%climatology(:) = 0 -allocate(clim_type%field_name(num_fields)) -allocate(clim_type%field_type(num_fields)) -allocate(clim_type%mr(num_fields)) -allocate(clim_type%out_of_bounds(num_fields)) -clim_type%out_of_bounds(:)=0 -allocate(clim_type%vert_interp(num_fields)) -clim_type%vert_interp(:)=0 -!-------------------------------------------------------------------- -!Allocate the space for the fields within the climatology data file. -allocate(varfields(nvar)) -!-------------------------------------------------------------------- -! Get the variable names out of the file. -call mpp_get_fields(clim_type%unit, varfields) -if(present(data_names)) then -!++lwh - if ( size(data_out_of_bounds(:)) /= size(data_names(:)) .and. size(data_out_of_bounds(:)) /= 1 ) & - call mpp_error(FATAL,'interpolator_init : The size of the data_out_of_bounds array must be 1& - & or size(data_names)') - if (present(vert_interp)) then - if( size(vert_interp(:)) /= size(data_names(:)) .and. size(vert_interp(:)) /= 1 ) & - call mpp_error(FATAL,'interpolator_init : The size of the vert_interp array must be 1& - & or size(data_names)') - endif -! Only read the fields named in data_names - do j=1,size(data_names(:)) - NAME_PRESENT = .FALSE. - do i=1,nvar - call mpp_get_atts(varfields(i),name=name,ndim=ndim,units=units) - if( trim(adjustl(lowercase(name))) == trim(adjustl(lowercase(data_names(j)))) ) then - units=chomp(units) - if (mpp_pe() == 0 ) write(*,*) 'Initializing src field : ',trim(name) - clim_type%field_name(j) = name - clim_type%field_type(j) = varfields(i) - clim_type%mr(j) = check_climo_units(units) - NAME_PRESENT = .TRUE. - if (present(clim_units)) clim_units(j) = units - clim_type%out_of_bounds(j) = data_out_of_bounds(MIN(j,SIZE(data_out_of_bounds(:))) ) - if( clim_type%out_of_bounds(j) /= CONSTANT .and. & - clim_type%out_of_bounds(j) /= ZERO ) & - call mpp_error(FATAL,"Interpolator_init: data_out_of_bounds must be& - & set to ZERO or CONSTANT") - if( present(vert_interp) ) then - clim_type%vert_interp(j) = vert_interp(MIN(j,SIZE(vert_interp(:))) ) - if( clim_type%vert_interp(j) /= INTERP_WEIGHTED_P .and. & - clim_type%vert_interp(j) /= INTERP_LINEAR_P ) & - call mpp_error(FATAL,"Interpolator_init: vert_interp must be& - & set to INTERP_WEIGHTED_P or INTERP_LINEAR_P") - else - clim_type%vert_interp(j) = INTERP_WEIGHTED_P - end if - endif - enddo - if(.not. NAME_PRESENT) & - call mpp_error(FATAL,'interpolator_init : Check names of fields being passed. ' & - //trim(data_names(j))//' does not exist.') - enddo -else - - if ( size(data_out_of_bounds(:)) /= nvar .and. size(data_out_of_bounds(:)) /= 1 ) & - call mpp_error(FATAL,'interpolator_init : The size of the out of bounds array must be 1& - & or the number of fields in the climatology dataset') - if ( present(vert_interp) ) then - if (size(vert_interp(:)) /= nvar .and. size(vert_interp(:)) /= 1 ) & - call mpp_error(FATAL,'interpolator_init : The size of the vert_interp array must be 1& - & or the number of fields in the climatology dataset') - endif - -! Read all the fields within the climatology data file. - do i=1,nvar - call mpp_get_atts(varfields(i),name=name,ndim=ndim,units=units) - if (mpp_pe() ==0 ) write(*,*) 'Initializing src field : ',trim(name) - clim_type%field_name(i) = lowercase(trim(name)) - clim_type%field_type(i) = varfields(i) - clim_type%mr(i) = check_climo_units(units) - if (present(clim_units)) clim_units(i) = units - clim_type%out_of_bounds(i) = data_out_of_bounds(MIN(i,SIZE(data_out_of_bounds(:))) ) - if( clim_type%out_of_bounds(i) /= CONSTANT .and. & - clim_type%out_of_bounds(i) /= ZERO ) & - call mpp_error(FATAL,"Interpolator_init: data_out_of_bounds must be& - & set to ZERO or CONSTANT") - if( present(vert_interp) ) then - clim_type%vert_interp(i) = vert_interp( MIN(i,SIZE(vert_interp(:)))) - if( clim_type%vert_interp(i) /= INTERP_WEIGHTED_P .and. & - clim_type%vert_interp(i) /= INTERP_LINEAR_P ) & - call mpp_error(FATAL,"Interpolator_init: vert_interp must be& - & set to INTERP_WEIGHTED_P or INTERP_LINEAR_P") - else - clim_type%vert_interp(i) = INTERP_WEIGHTED_P - end if - end do -!--lwh -endif - -deallocate(varfields) - - -if( clim_type%TIME_FLAG .eq. SEASONAL ) then -! Read all the data at this point. - do i=1,num_fields - do n = 1, ntime - call interp_read_data_mppio( clim_type, clim_type%field_type(i), & - clim_type%data(:,:,:,n,i), n, i, base_time ) - enddo - enddo -endif - -if( clim_type%TIME_FLAG .eq. LINEAR .and. read_all_on_init) then -! Read all the data at this point. - do i=1,num_fields - do n = 1, ntime - call interp_read_data_mppio( clim_type, clim_type%field_type(i), & - clim_type%data(:,:,:,n,i), n, i, base_time ) - enddo - enddo - - call mpp_close (unit) -endif - -if( clim_type%TIME_FLAG .eq. NOTIME ) then -! Read all the data at this point. - do i=1,num_fields - call interp_read_data_mppio_no_time_axis( clim_type, clim_type%field_type(i),& - clim_type%data(:,:,:,1,i), i ) - enddo - call mpp_close (unit) -endif - -if (present (single_year_file)) then - single_year_file = clim_type%climatological_year -endif - -end subroutine mppio_interpolator_init - -!> @brief interp_read_data_mppio receives various climate data as inputs and -!! returns a horizontally interpolated climatology field. -!! -!! @param [in] The interpolate type which contains the data -!! @param [in] The field type -!! @param [in] The index of the time slice of the climatology that you wish -!to read -!! @param [in] OPTIONAL: The index of the field name that you are trying to -!read -!! @param [in]