!*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** module axis_utils_mod ! !M.J. Harrison ! !Bruce Wyman ! ! ! A set of utilities for manipulating axes and extracting axis ! attributes ! ! ! ! subroutine get_axis_cart(axis,cart) : Returns X,Y,Z or T cartesian attribute ! subroutine get_axis_bounds(axis,axis_bound,axes) : Return axis_bound either from an array of ! available axes, or defined based on axis mid-points ! function get_axis_modulo : Returns true if axis has the modulo attribute ! function get_axis_fold : Returns is axis is folded at a boundary (non-standard meta-data) ! function lon_in_range : Returns lon_strt <= longitude <= lon_strt+360 ! subroutine tranlon : Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. ! subroutine nearest_index : Return index of nearest point along axis ! ! ! use mpp_io_mod, only: axistype, atttype, default_axis, default_att, & mpp_get_atts, mpp_get_axis_data, mpp_modify_meta, & mpp_get_att_name, mpp_get_att_type, mpp_get_att_char, & mpp_get_att_length, mpp_get_axis_bounds use mpp_mod, only: mpp_error, FATAL, stdout use fms_mod, only: lowercase, string_array_index, fms_error_handler implicit none # include public get_axis_cart, get_axis_bounds, get_axis_modulo, get_axis_fold, lon_in_range, & tranlon, frac_index, nearest_index, interp_1d, get_axis_modulo_times private integer, parameter :: maxatts = 100 real, parameter :: epsln= 1.e-10 real, parameter :: fp5 = 0.5, f360 = 360.0 ! Include variable "version" to be written to log file. #include interface interp_1d module procedure interp_1d_1d module procedure interp_1d_2d module procedure interp_1d_3d end interface contains subroutine get_axis_cart(axis, cart) type(axistype), intent(in) :: axis character(len=1), intent(out) :: cart character(len=1) :: axis_cart character(len=16), dimension(2) :: lon_names, lat_names character(len=16), dimension(3) :: z_names character(len=16), dimension(2) :: t_names character(len=16), dimension(3) :: lon_units, lat_units character(len=8) , dimension(4) :: z_units character(len=3) , dimension(6) :: t_units character(len=32) :: name integer :: i,j lon_names = (/'lon','x '/) lat_names = (/'lat','y '/) z_names = (/'depth ','height','z '/) t_names = (/'time','t '/) lon_units = (/'degrees_e ', 'degrees_east', 'degreese '/) lat_units = (/'degrees_n ', 'degrees_north', 'degreesn '/) z_units = (/'cm ','m ','pa ','hpa'/) t_units = (/'sec', 'min','hou','day','mon','yea'/) call mpp_get_atts(axis,cartesian=axis_cart) cart = 'N' if ( lowercase(axis_cart) == 'x' ) cart = 'X' if ( lowercase(axis_cart) == 'y' ) cart = 'Y' if ( lowercase(axis_cart) == 'z' ) cart = 'Z' if ( lowercase(axis_cart) == 't' ) cart = 'T' if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then call mpp_get_atts(axis,name=name) name = lowercase(name) do i=1,size(lon_names(:)) if (trim(name(1:3)) == trim(lon_names(i))) cart = 'X' enddo do i=1,size(lat_names(:)) if (trim(name(1:3)) == trim(lat_names(i))) cart = 'Y' enddo do i=1,size(z_names(:)) if (trim(name) == trim(z_names(i))) cart = 'Z' enddo do i=1,size(t_names(:)) if (trim(name) == t_names(i)) cart = 'T' enddo end if if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then call mpp_get_atts(axis,units=name) name = lowercase(name) do i=1,size(lon_units(:)) if (trim(name) == trim(lon_units(i))) cart = 'X' enddo do i=1,size(lat_units(:)) if (trim(name) == trim(lat_units(i))) cart = 'Y' enddo do i=1,size(z_units(:)) if (trim(name) == trim(z_units(i))) cart = 'Z' enddo do i=1,size(t_units(:)) if (name(1:3) == trim(t_units(i))) cart = 'T' enddo end if return end subroutine get_axis_cart subroutine get_axis_bounds(axis,axis_bound,axes,bnd_name,err_msg) type(axistype), intent(in) :: axis type(axistype), intent(inout) :: axis_bound type(axistype), intent(in), dimension(:) :: axes character(len=*), intent(inout), optional :: bnd_name character(len=*), intent(out), optional :: err_msg real, dimension(:), allocatable :: data, tmp integer :: i, len character(len=128) :: name, units character(len=256) :: longname character(len=1) :: cartesian logical :: bounds_found if(present(err_msg)) then err_msg = '' endif axis_bound = default_axis call mpp_get_atts(axis,units=units,longname=longname,& cartesian=cartesian, len=len) if(len .LE. 0) return allocate(data(len+1)) bounds_found = mpp_get_axis_bounds(axis, data, name=name) longname = trim(longname)//' bounds' if(.not.bounds_found .and. len>1 ) then ! The following calculation can not be done for len=1 call mpp_get_atts(axis,name=name) name = trim(name)//'_bnds' allocate(tmp(len)) call mpp_get_axis_data(axis,tmp) do i=2,len data(i)= tmp(i-1)+fp5*(tmp(i)-tmp(i-1)) enddo data(1)= tmp(1)- fp5*(tmp(2)-tmp(1)) if (abs(data(1)) < epsln) data(1) = 0.0 data(len+1)= tmp(len)+ fp5*(tmp(len)-tmp(len-1)) if (data(1) == 0.0) then if (abs(data(len+1)-360.) > epsln) data(len+1)=360.0 endif endif if(bounds_found .OR. len>1) then call mpp_modify_meta(axis_bound,name=name,units=units,longname=& longname,cartesian=cartesian,data=data) endif if(allocated(tmp)) deallocate(tmp) deallocate(data) return end subroutine get_axis_bounds function get_axis_modulo(axis) type(axistype) :: axis logical :: get_axis_modulo integer :: natt, i type(atttype), dimension(:), allocatable :: atts call mpp_get_atts(axis,natts=natt) allocate(atts(natt)) call mpp_get_atts(axis,atts=atts) get_axis_modulo=.false. do i = 1,natt if (lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo') get_axis_modulo = .true. enddo deallocate(atts) return end function get_axis_modulo function get_axis_modulo_times(axis, tbeg, tend) logical :: get_axis_modulo_times type(axistype), intent(in) :: axis character(len=*), intent(out) :: tbeg, tend integer :: natt, i type(atttype), dimension(:), allocatable :: atts logical :: found_tbeg, found_tend call mpp_get_atts(axis,natts=natt) allocate(atts(natt)) call mpp_get_atts(axis,atts=atts) found_tbeg = .false. found_tend = .false. do i = 1,natt if(lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo_beg') then if(mpp_get_att_length(atts(i)) > len(tbeg)) then call mpp_error(FATAL,'error in get: len(tbeg) too small to hold attribute') endif tbeg = trim(mpp_get_att_char(atts(i))) found_tbeg = .true. endif if(lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo_end') then if(mpp_get_att_length(atts(i)) > len(tend)) then call mpp_error(FATAL,'error in get: len(tend) too small to hold attribute') endif tend = trim(mpp_get_att_char(atts(i))) found_tend = .true. endif enddo if(found_tbeg .and. .not.found_tend) then call mpp_error(FATAL,'error in get: Found modulo_beg but not modulo_end') endif if(.not.found_tbeg .and. found_tend) then call mpp_error(FATAL,'error in get: Found modulo_end but not modulo_beg') endif get_axis_modulo_times = found_tbeg end function get_axis_modulo_times function get_axis_fold(axis) type(axistype) :: axis logical :: get_axis_fold integer :: natt, i type(atttype), dimension(:), allocatable :: atts call mpp_get_atts(axis,natts=natt) allocate(atts(natt)) call mpp_get_atts(axis,atts=atts) get_axis_fold=.false. do i = 1,natt if (mpp_get_att_char(atts(i)) == 'fold_top') get_axis_fold = .true. enddo deallocate(atts) return end function get_axis_fold function lon_in_range(lon, l_strt) real :: lon, l_strt, lon_in_range, l_end lon_in_range = lon l_end = l_strt+360. if (abs(lon_in_range - l_strt) < 1.e-4) then lon_in_range = l_strt return endif if (abs(lon_in_range - l_end) < 1.e-4) then lon_in_range = l_strt return endif do if (lon_in_range < l_strt) then lon_in_range = lon_in_range + f360; else if (lon_in_range > l_end) then lon_in_range = lon_in_range - f360; else exit end if end do end function lon_in_range subroutine tranlon(lon, lon_start, istrt) ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. ! also, the first istrt-1 entries are moved to the end of the array ! ! e.g. ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 real, intent(inout), dimension(:) :: lon real, intent(in) :: lon_start integer, intent(out) :: istrt integer :: len, i real :: lon_strt, tmp(size(lon(:))-1) len = size(lon(:)) do i=1,len lon(i) = lon_in_range(lon(i),lon_start) enddo istrt=0 do i=1,len-1 if (lon(i+1) < lon(i)) then istrt=i+1 exit endif enddo if (istrt>1) then ! grid is not monotonic if (abs(lon(len)-lon(1)) < epsln) then tmp = cshift(lon(1:len-1),istrt-1) lon(1:len-1) = tmp lon(len) = lon(1) else lon = cshift(lon,istrt-1) endif lon_strt = lon(1) do i=2,len+1 lon(i) = lon_in_range(lon(i),lon_strt) lon_strt = lon(i) enddo endif return end subroutine tranlon function frac_index (value, array) !======================================================================= ! ! nearest_index = index of nearest data point within "array" corresponding to ! "value". ! ! inputs: ! ! value = arbitrary data...same units as elements in "array" ! array = array of data points (must be monotonically increasing) ! ! output: ! ! nearest_index = index of nearest data point to "value" ! if "value" is outside the domain of "array" then nearest_index = 1 ! or "ia" depending on whether array(1) or array(ia) is ! closest to "value" ! ! note: if "array" is dimensioned array(0:ia) in the calling ! program, then the returned index should be reduced ! by one to account for the zero base. ! ! example: ! ! let model depths be defined by the following: ! parameter (km=5) ! dimension z(km) ! data z /5.0, 10.0, 50.0, 100.0, 250.0/ ! ! k1 = nearest_index (12.5, z, km) ! k2 = nearest_index (0.0, z, km) ! ! k1 would be set to 2, and k2 would be set to 1 so that ! z(k1) would be the nearest data point to 12.5 and z(k2) would ! be the nearest data point to 0.0 ! !======================================================================= integer :: ia, i, ii, unit real :: value, frac_index real, dimension(:) :: array logical keep_going ia = size(array(:)) do i=2,ia if (array(i) < array(i-1)) then unit = stdout() write (unit,*) '=> Error: "frac_index" array must be monotonically increasing when searching for nearest value to ',& value write (unit,*) ' array(i) < array(i-1) for i=',i write (unit,*) ' array(i) for i=1..ia follows:' do ii=1,ia write (unit,*) 'i=',ii, ' array(i)=',array(ii) enddo call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.') endif enddo if (value < array(1) .or. value > array(ia)) then ! if (value < array(1)) frac_index = 1. ! if (value > array(ia)) frac_index = float(ia) frac_index = -1.0 else i=1 keep_going = .true. do while (i <= ia .and. keep_going) i = i+1 if (value <= array(i)) then frac_index = float(i-1) + (value-array(i-1))/(array(i)-array(i-1)) keep_going = .false. endif enddo endif end function frac_index function nearest_index (value, array) !======================================================================= ! ! nearest_index = index of nearest data point within "array" corresponding to ! "value". ! ! inputs: ! ! value = arbitrary data...same units as elements in "array" ! array = array of data points (must be monotonically increasing) ! ia = dimension of "array" ! ! output: ! ! nearest_index = index of nearest data point to "value" ! if "value" is outside the domain of "array" then nearest_index = 1 ! or "ia" depending on whether array(1) or array(ia) is ! closest to "value" ! ! note: if "array" is dimensioned array(0:ia) in the calling ! program, then the returned index should be reduced ! by one to account for the zero base. ! ! example: ! ! let model depths be defined by the following: ! parameter (km=5) ! dimension z(km) ! data z /5.0, 10.0, 50.0, 100.0, 250.0/ ! ! k1 = nearest_index (12.5, z, km) ! k2 = nearest_index (0.0, z, km) ! ! k1 would be set to 2, and k2 would be set to 1 so that ! z(k1) would be the nearest data point to 12.5 and z(k2) would ! be the nearest data point to 0.0 ! !======================================================================= integer :: nearest_index, ia, i, ii, unit real :: value real, dimension(:) :: array logical keep_going ia = size(array(:)) do i=2,ia if (array(i) < array(i-1)) then unit = stdout() write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing & &when searching for nearest value to ',value write (unit,*) ' array(i) < array(i-1) for i=',i write (unit,*) ' array(i) for i=1..ia follows:' do ii=1,ia write (unit,*) 'i=',ii, ' array(i)=',array(ii) enddo call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.') endif enddo if (value < array(1) .or. value > array(ia)) then if (value < array(1)) nearest_index = 1 if (value > array(ia)) nearest_index = ia else i=1 keep_going = .true. do while (i <= ia .and. keep_going) i = i+1 if (value <= array(i)) then nearest_index = i if (array(i)-value > value-array(i-1)) nearest_index = i-1 keep_going = .false. endif enddo endif end function nearest_index !############################################################################# subroutine interp_1d_linear(grid1,grid2,data1,data2) real, dimension(:), intent(in) :: grid1, data1, grid2 real, dimension(:), intent(inout) :: data2 integer :: n1, n2, i, n, ext real :: w n1 = size(grid1(:)) n2 = size(grid2(:)) do i=2,n1 if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') enddo do i=2,n2 if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') enddo if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1') do i=1,n2 n = nearest_index(grid2(i),grid1) if (grid1(n) < grid2(i)) then w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n)) data2(i) = (1.-w)*data1(n) + w*data1(n+1) else if(n==1) then data2(i) = data1(n) else w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1)) data2(i) = (1.-w)*data1(n-1) + w*data1(n) endif endif enddo return end subroutine interp_1d_linear !################################################################### subroutine interp_1d_cubic_spline(grid1, grid2, data1, data2, yp1, ypn) real, dimension(:), intent(in) :: grid1, grid2, data1 real, dimension(:), intent(inout) :: data2 real, intent(in) :: yp1, ypn real, dimension(size(grid1)) :: y2, u real :: sig, p, qn, un, h, a ,b integer :: n, m, i, k, klo, khi n = size(grid1(:)) m = size(grid2(:)) do i=2,n if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') enddo do i=2,m if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') enddo if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1') if (yp1 >.99e30) then y2(1)=0. u(1)=0. else y2(1)=-0.5 u(1)=(3./(grid1(2)-grid1(1)))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1) endif do i=2,n-1 sig=(grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1)) p=sig*y2(i-1)+2. y2(i)=(sig-1.)/p u(i)=(6.*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) & /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p enddo if (ypn > .99e30) then qn=0. un=0. else qn=0.5 un=(3./(grid1(n)-grid1(n-1)))*(ypn-(data1(n)-data1(n-1))/(grid1(n)-grid1(n-1))) endif y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) do k=n-1,1,-1 y2(k)=y2(k)*y2(k+1)+u(k) enddo do k = 1, m n = nearest_index(grid2(k),grid1) if (grid1(n) < grid2(k)) then klo = n else if(n==1) then klo = n else klo = n -1 endif endif khi = klo+1 h = grid1(khi)-grid1(klo) a = (grid1(khi) - grid2(k))/h b = (grid2(k) - grid1(klo))/h data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2)/6. enddo end subroutine interp_1d_cubic_spline !################################################################### subroutine interp_1d_1d(grid1,grid2,data1,data2, method, yp1, yp2) real, dimension(:), intent(in) :: grid1, data1, grid2 real, dimension(:), intent(inout) :: data2 character(len=*), optional, intent(in) :: method real, optional, intent(in) :: yp1, yp2 real :: y1, y2 character(len=32) :: interp_method integer :: k2, ks, ke k2 = size(grid2(:)) interp_method = "linear" if(present(method)) interp_method = method y1 = 1.0e30 if(present(yp1)) y1 = yp1 y2 = 1.0e30 if(present(yp2)) y2 = yp2 call find_index(grid1, grid2(1), grid2(k2), ks, ke) select case(trim(interp_method)) case("linear") call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2) case("cubic_spline") call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2) case default call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") end select return end subroutine interp_1d_1d !################################################################### subroutine interp_1d_2d(grid1,grid2,data1,data2) real, dimension(:,:), intent(in) :: grid1, data1, grid2 real, dimension(:,:), intent(inout) :: data2 integer :: n1, n2, i, n, k2, ks, ke real :: w n1 = size(grid1,1) n2 = size(grid2,1) k2 = size(grid2,2) if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch') do n=1,n1 call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke) call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:)) enddo return end subroutine interp_1d_2d !################################################################### subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2) real, dimension(:,:,:), intent(in) :: grid1, data1, grid2 real, dimension(:,:,:), intent(inout) :: data2 character(len=*), optional, intent(in) :: method real, optional, intent(in) :: yp1, yp2 integer :: n1, n2, m1, m2, k2, i, n, m real :: w, y1, y2 character(len=32) :: interp_method integer :: ks, ke n1 = size(grid1,1) n2 = size(grid2,1) m1 = size(grid1,2) m2 = size(grid2,2) k2 = size(grid2,3) interp_method = "linear" if(present(method)) interp_method = method y1 = 1.0e30 if(present(yp1)) y1 = yp1 y2 = 1.0e30 if(present(yp2)) y2 = yp2 if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch') select case(trim(interp_method)) case("linear") do m=1,m1 do n=1,n1 call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:)) enddo enddo case("cubic_spline") do m=1,m1 do n=1,n1 call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2) enddo enddo case default call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") end select return end subroutine interp_1d_3d !##################################################################### subroutine find_index(grid1, xs, xe, ks, ke) real, dimension(:), intent(in) :: grid1 real, intent(in) :: xs, xe integer, intent(out) :: ks, ke integer :: k, nk nk = size(grid1(:)) ks = 0; ke = 0 do k = 1, nk-1 if(grid1(k) <= xs .and. grid1(k+1) > xs ) then ks = k exit endif enddo do k = nk, 2, -1 if(grid1(k) >= xe .and. grid1(k-1) < xe ) then ke = k exit endif enddo if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1') if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') end subroutine find_index end module axis_utils_mod