!***********************************************************************
!* 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 mosaic_mod
!
! Zhi Liang
!
!
!
! mosaic_mod implements some utility routines to read mosaic information.
!
!
! mosaic_mod implements some utility routines to read mosaic information.
! The information includes number of tiles and contacts in the mosaic,
! mosaic grid resolution of each tile, mosaic contact information, mosaic exchange
! grid information. Each routine will call a C-version routine to get these information.
!
use fms_mod, only : write_version_number
use mpp_mod, only : mpp_error, FATAL, mpp_pe, mpp_root_pe
use mpp_io_mod, only : MPP_MULTI
use fms_io_mod, only : dimension_size, field_exist, read_data, read_compressed
use constants_mod, only : PI, RADIUS
implicit none
private
character(len=*), parameter :: &
grid_dir = 'INPUT/' ! root directory for all grid files
integer, parameter :: &
MAX_NAME = 256, & ! max length of the variable names
MAX_FILE = 1024, & ! max length of the file names
X_REFINE = 2, & ! supergrid size/model grid size in x-direction
Y_REFINE = 2 ! supergrid size/model grid size in y-direction
! --- public interface
public :: get_mosaic_ntiles
public :: get_mosaic_ncontacts
public :: get_mosaic_grid_sizes
public :: get_mosaic_contact
public :: get_mosaic_xgrid_size
public :: get_mosaic_xgrid
public :: calc_mosaic_grid_area
public :: calc_mosaic_grid_great_circle_area
public :: is_inside_polygon
logical :: module_is_initialized = .true.
! Include variable "version" to be written to log file.
#include
contains
!#######################################################################
!
!
! Initialize the mosaic_mod.
!
!
! Initialization routine for the mosaic module. It writes the
! version information to the log file.
!
!
! call mosaic_init ( )
!
subroutine mosaic_init()
if (module_is_initialized) return
module_is_initialized = .TRUE.
!--------- write version number and namelist ------------------
call write_version_number("MOSAIC_MOD", version)
end subroutine mosaic_init
!
!#######################################################################
!
!
! return exchange grid size of mosaic xgrid file.
!
!
! return exchange grid size of mosaic xgrid file.
!
!
! nxgrid = get_mosaic_xgrid_size(xgrid_file)
!
!
! The file that contains exchange grid information.
!
function get_mosaic_xgrid_size(xgrid_file)
character(len=*), intent(in) :: xgrid_file
integer :: get_mosaic_xgrid_size
get_mosaic_xgrid_size = dimension_size(xgrid_file, "ncells", no_domain=.TRUE.)
return
end function get_mosaic_xgrid_size
!
!#######################################################################
!
!
! get exchange grid information from mosaic xgrid file.
!
!
! get exchange grid information from mosaic xgrid file.
!
!
! call get_mosaic_xgrid(xgrid_file, nxgrid, i1, j1, i2, j2, area)
!
!
! The file that contains exchange grid information.
!
!
! number of exchange grid in xgrid_file
!
!
! i and j-index in grid 1 of exchange grid.
!
!
! i and j-index in grid 2 of exchange grid.
!
!
! area of the exchange grid. The area is scaled to represent unit earth area.
!
subroutine get_mosaic_xgrid(xgrid_file, i1, j1, i2, j2, area, ibegin, iend)
character(len=*), intent(in) :: xgrid_file
integer, intent(inout) :: i1(:), j1(:), i2(:), j2(:)
real, intent(inout) :: area(:)
integer, optional, intent(in) :: ibegin, iend
integer :: start(4), nread(4), istart
real, dimension(2, size(i1(:))) :: tile1_cell, tile2_cell
integer :: nxgrid, n
real :: garea
real :: get_global_area;
garea = get_global_area();
! When start and nread present, make sure nread(1) is the same as the size of the data
if(present(ibegin) .and. present(iend)) then
istart = ibegin
nxgrid = iend - ibegin + 1
if(nxgrid .NE. size(i1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i1(:))")
if(nxgrid .NE. size(j1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j1(:))")
if(nxgrid .NE. size(i2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i2(:))")
if(nxgrid .NE. size(j2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j2(:))")
if(nxgrid .NE. size(area(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(area(:))")
else
istart = 1
nxgrid = size(i1(:))
endif
start = 1; nread = 1
start(1) = istart; nread(1) = nxgrid
call read_compressed(xgrid_file, 'xgrid_area', area, start=start, nread=nread, threading=MPP_MULTI)
start = 1; nread = 1
nread(1) = 2
start(2) = istart; nread(2) = nxgrid
call read_compressed(xgrid_file, 'tile1_cell', tile1_cell, start=start, nread=nread, threading=MPP_MULTI)
call read_compressed(xgrid_file, 'tile2_cell', tile2_cell, start=start, nread=nread, threading=MPP_MULTI)
do n = 1, nxgrid
i1(n) = tile1_cell(1,n)
j1(n) = tile1_cell(2,n)
i2(n) = tile2_cell(1,n)
j2(n) = tile2_cell(2,n)
area(n) = area(n)/garea
end do
return
end subroutine get_mosaic_xgrid
!
!###############################################################################
!
!
! get number of tiles in the mosaic_file.
!
!
! get number of tiles in the mosaic_file.
!
!
! ntiles = get_mosaic_ntiles( mosaic_file)
!
!
! The file that contains mosaic information.
!
function get_mosaic_ntiles(mosaic_file)
character(len=*), intent(in) :: mosaic_file
integer :: get_mosaic_ntiles
get_mosaic_ntiles = dimension_size(mosaic_file, "ntiles")
return
end function get_mosaic_ntiles
!
!###############################################################################
!
!
! get number of contacts in the mosaic_file.
!
!
! get number of contacts in the mosaic_file.
!
!
! ntiles = get_mosaic_ncontacts( mosaic_file)
!
!
! The file that contains mosaic information.
!
function get_mosaic_ncontacts( mosaic_file)
character(len=*), intent(in) :: mosaic_file
integer :: get_mosaic_ncontacts
character(len=len_trim(mosaic_file)+1) :: mfile
integer :: strlen
integer :: read_mosaic_ncontacts
if(field_exist(mosaic_file, "contacts") ) then
get_mosaic_ncontacts = dimension_size(mosaic_file, "ncontact", no_domain=.TRUE.)
else
get_mosaic_ncontacts = 0
endif
return
end function get_mosaic_ncontacts
!
!###############################################################################
!
!
! get grid size of each tile from mosaic_file
!
!
! get grid size of each tile from mosaic_file
!
!
! call get_mosaic_grid_sizes(mosaic_file, nx, ny)
!
!
! The file that contains mosaic information.
!
!
! List of grid size in x-direction of each tile.
!
!
! List of grid size in y-direction of each tile.
!
subroutine get_mosaic_grid_sizes( mosaic_file, nx, ny)
character(len=*), intent(in) :: mosaic_file
integer, dimension(:), intent(inout) :: nx, ny
character(len=MAX_FILE) :: gridfile
integer :: ntiles, n
ntiles = get_mosaic_ntiles(mosaic_file)
if(ntiles .NE. size(nx(:)) .OR. ntiles .NE. size(ny(:)) ) then
call mpp_error(FATAL, "get_mosaic_grid_sizes: size of nx/ny does not equal to ntiles")
endif
do n = 1, ntiles
call read_data(mosaic_file, 'gridfiles', gridfile, level=n)
gridfile = grid_dir//trim(gridfile)
nx(n) = dimension_size(gridfile, "nx")
ny(n) = dimension_size(gridfile, "ny")
if(mod(nx(n),x_refine) .NE. 0) call mpp_error(FATAL, "get_mosaic_grid_sizes: nx is not divided by x_refine");
if(mod(ny(n),y_refine) .NE. 0) call mpp_error(FATAL, "get_mosaic_grid_sizes: ny is not divided by y_refine");
nx(n) = nx(n)/x_refine;
ny(n) = ny(n)/y_refine;
enddo
return
end subroutine get_mosaic_grid_sizes
!
!###############################################################################
!
!
! get contact information from mosaic_file
!
!
! get contact information from mosaic_file
!
!
! call get_mosaic_contact(mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1,
! istart2, iend2, jstart2, jend2)
!
!
! The file that contains mosaic information.
!
!
! list tile number in tile 1 of each contact.
!
!
! list tile number in tile 2 of each contact.
!
!
! list starting i-index in tile 1 of each contact.
!
!
! list ending i-index in tile 1 of each contact.
!
!
! list starting j-index in tile 1 of each contact.
!
!
! list ending j-index in tile 1 of each contact.
!
!
! list starting i-index in tile 2 of each contact.
!
!
! list ending i-index in tile 2 of each contact.
!
!
! list starting j-index in tile 2 of each contact.
!
!
! list ending j-index in tile 2 of each contact.
!
subroutine get_mosaic_contact( mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1, &
istart2, iend2, jstart2, jend2)
character(len=*), intent(in) :: mosaic_file
integer, dimension(:), intent(inout) :: tile1, tile2
integer, dimension(:), intent(inout) :: istart1, iend1, jstart1, jend1
integer, dimension(:), intent(inout) :: istart2, iend2, jstart2, jend2
character(len=MAX_NAME), allocatable :: gridtiles(:)
character(len=MAX_NAME) :: contacts
character(len=MAX_NAME) :: strlist(8)
integer :: ntiles, n, m, ncontacts, nstr, ios
integer :: i1_type, j1_type, i2_type, j2_type
logical :: found
ntiles = get_mosaic_ntiles(mosaic_file)
allocate(gridtiles(ntiles))
do n = 1, ntiles
call read_data(mosaic_file, 'gridtiles', gridtiles(n), level=n)
enddo
ncontacts = get_mosaic_ncontacts(mosaic_file)
do n = 1, ncontacts
call read_data(mosaic_file, "contacts", contacts, level=n)
nstr = parse_string(contacts, ":", strlist)
if(nstr .NE. 4) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): number of elements in contact seperated by :/:: should be 4")
found = .false.
do m = 1, ntiles
if(trim(gridtiles(m)) == trim(strlist(2)) ) then !found the tile name
found = .true.
tile1(n) = m
exit
endif
enddo
if(.not.found) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact):the first tile name specified in contact is not found in tile list")
found = .false.
do m = 1, ntiles
if(trim(gridtiles(m)) == trim(strlist(4)) ) then !found the tile name
found = .true.
tile2(n) = m
exit
endif
enddo
if(.not.found) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact):the second tile name specified in contact is not found in tile list")
call read_data(mosaic_file, "contact_index", contacts, level=n)
nstr = parse_string(contacts, ":,", strlist)
if(nstr .NE. 8) then
if(mpp_pe()==mpp_root_pe()) then
print*, "nstr is ", nstr
print*, "contacts is ", contacts
do m = 1, nstr
print*, "strlist is ", trim(strlist(m))
enddo
endif
call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): number of elements in contact_index seperated by :/, should be 8")
endif
read(strlist(1), *, iostat=ios) istart1(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading istart1")
read(strlist(2), *, iostat=ios) iend1(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading iend1")
read(strlist(3), *, iostat=ios) jstart1(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading jstart1")
read(strlist(4), *, iostat=ios) jend1(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading jend1")
read(strlist(5), *, iostat=ios) istart2(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading istart2")
read(strlist(6), *, iostat=ios) iend2(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading iend2")
read(strlist(7), *, iostat=ios) jstart2(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading jstart2")
read(strlist(8), *, iostat=ios) jend2(n)
if(ios .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): Error in reading jend2")
i1_type = transfer_to_model_index(istart1(n), iend1(n), x_refine)
j1_type = transfer_to_model_index(jstart1(n), jend1(n), y_refine)
i2_type = transfer_to_model_index(istart2(n), iend2(n), x_refine)
j2_type = transfer_to_model_index(jstart2(n), jend2(n), y_refine)
if( i1_type == 0 .AND. j1_type == 0 ) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): istart1==iend1 and jstart1==jend1")
if( i2_type == 0 .AND. j2_type == 0 ) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): istart2==iend2 and jstart2==jend2")
if( i1_type + j1_type .NE. i2_type + j2_type ) call mpp_error(FATAL, &
"mosaic_mod(get_mosaic_contact): It is not a line or overlap contact")
enddo
deallocate(gridtiles)
end subroutine get_mosaic_contact
!
function transfer_to_model_index(istart, iend, refine_ratio)
integer, intent(inout) :: istart, iend
integer :: refine_ratio
integer :: transfer_to_model_index
integer :: istart_in, iend_in
istart_in = istart
iend_in = iend
if( istart_in == iend_in ) then
transfer_to_model_index = 0
istart = (istart_in + 1)/refine_ratio
iend = istart
else
transfer_to_model_index = 1
if( iend_in > istart_in ) then
istart = istart_in + 1
iend = iend_in
else
istart = istart_in
iend = iend_in + 1
endif
if( mod(istart, refine_ratio) .NE. 0 .OR. mod(iend,refine_ratio) .NE. 0) call mpp_error(FATAL, &
"mosaic_mod(transfer_to_model_index): mismatch between refine_ratio and istart/iend")
istart = istart/refine_ratio
iend = iend/refine_ratio
endif
return
end function transfer_to_model_index
!###############################################################################
!
!
! calculate grid cell area.
!
!
! calculate the grid cell area. The purpose of this routine is to make
! sure the consistency between model grid area and exchange grid area.
!
!
! call calc_mosaic_grid_area(lon, lat, area)
!
!
! geographical longitude of grid cell vertices.
!
!
! geographical latitude of grid cell vertices.
!
!
! grid cell area.
!
subroutine calc_mosaic_grid_area(lon, lat, area)
real, dimension(:,:), intent(in) :: lon
real, dimension(:,:), intent(in) :: lat
real, dimension(:,:), intent(inout) :: area
integer :: nlon, nlat
nlon = size(area,1)
nlat = size(area,2)
! make sure size of lon, lat and area are consitency
if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) &
call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1")
if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) &
call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1")
call get_grid_area( nlon, nlat, lon, lat, area)
end subroutine calc_mosaic_grid_area
!
!###############################################################################
!
!
! calculate grid cell area using great cirlce algorithm
!
!
! calculate the grid cell area. The purpose of this routine is to make
! sure the consistency between model grid area and exchange grid area.
!
!
! call calc_mosaic_grid_great_circle_area(lon, lat, area)
!
!
! geographical longitude of grid cell vertices.
!
!
! geographical latitude of grid cell vertices.
!
!
! grid cell area.
!
subroutine calc_mosaic_grid_great_circle_area(lon, lat, area)
real, dimension(:,:), intent(in) :: lon
real, dimension(:,:), intent(in) :: lat
real, dimension(:,:), intent(inout) :: area
integer :: nlon, nlat
nlon = size(area,1)
nlat = size(area,2)
! make sure size of lon, lat and area are consitency
if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) &
call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1")
if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) &
call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1")
call get_grid_great_circle_area( nlon, nlat, lon, lat, area)
end subroutine calc_mosaic_grid_great_circle_area
!
!#####################################################################
! This function check if a point (lon1,lat1) is inside a polygon (lon2(:), lat2(:))
! lon1, lat1, lon2, lat2 are in radians.
function is_inside_polygon(lon1, lat1, lon2, lat2 )
real, intent(in) :: lon1, lat1
real, intent(in) :: lon2(:), lat2(:)
logical :: is_inside_polygon
real, dimension(size(lon2(:))) :: x2, y2, z2
integer :: npts, isinside
integer :: inside_a_polygon
npts = size(lon2(:))
isinside = inside_a_polygon(lon1, lat1, npts, lon2, lat2)
if(isinside == 1) then
is_inside_polygon = .TRUE.
else
is_inside_polygon = .FALSE.
endif
return
end function is_inside_polygon
function parse_string(string, set, value)
character(len=*), intent(in) :: string
character(len=*), intent(in) :: set
character(len=*), intent(out) :: value(:)
integer :: parse_string
integer :: nelem, length, first, last
nelem = size(value(:))
length = len_trim(string)
first = 1; last = 0
parse_string = 0
do while(first .LE. length)
parse_string = parse_string + 1
if(parse_string>nelem) then
call mpp_error(FATAL, "mosaic_mod(parse_string) : number of element is greater than size(value(:))")
endif
last = first - 1 + scan(string(first:length), set)
if(last == first-1 ) then ! not found, end of string
value(parse_string) = string(first:length)
exit
else
if(last <= first) then
call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first")
endif
value(parse_string) = string(first:(last-1))
first = last + 1
! scan to make sure the next is not the character in the set
do while (first == last+1)
last = first - 1 + scan(string(first:length), set)
if(last == first) then
first = first+1
else
exit
endif
end do
endif
enddo
return
end function parse_string
end module mosaic_mod