/wrfv2_fire/external/io_esmf/io_esmf.F90
FORTRAN Modern | 1851 lines | 1493 code | 143 blank | 215 comment | 14 complexity | f78ba515f4735502699a0e048e66685d MD5 | raw file
Possible License(s): AGPL-1.0
Large files files are truncated, but you can click here to view the full file
- MODULE module_ext_esmf
- ! 5.2.0r USE ESMF_Mod
- USE ESMF
- USE module_esmf_extensions
- IMPLICIT NONE
- TYPE grid_ptr
- TYPE(ESMF_Grid), POINTER :: ptr
- ! use these for error-checking for now...
- INTEGER :: ide_save
- INTEGER :: jde_save
- INTEGER :: kde_save
- LOGICAL :: in_use
- END TYPE grid_ptr
- !TODO: encapsulate this state into a class...
- INTEGER, PARAMETER :: int_num_handles = 99
- LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, okay_to_read, &
- opened_for_write, opened_for_read, &
- int_handle_in_use
- TYPE(grid_ptr) :: grid(int_num_handles)
- ! convenience...
- CHARACTER (256) :: msg
- #include "wrf_io_flags.h"
- #include "wrf_status_codes.h"
- CONTAINS
- LOGICAL FUNCTION int_valid_handle( handle )
- IMPLICIT NONE
- INTEGER, INTENT(IN) :: handle
- int_valid_handle = ( handle .ge. 8 .and. handle .le. int_num_handles )
- END FUNCTION int_valid_handle
- SUBROUTINE int_get_fresh_handle( retval )
- INTEGER i, retval
- retval = -1
- ! dont use first 8 handles
- DO i = 8, int_num_handles
- IF ( .NOT. int_handle_in_use(i) ) THEN
- retval = i
- GOTO 33
- ENDIF
- ENDDO
- 33 CONTINUE
- IF ( retval < 0 ) THEN
- CALL wrf_error_fatal( "io_esmf.F90: int_get_fresh_handle() out of handles")
- ENDIF
- int_handle_in_use(retval) = .TRUE.
- END SUBROUTINE int_get_fresh_handle
- ! parse comma separated list of VARIABLE=VALUE strings and return the
- ! value for the matching variable if such exists, otherwise return
- ! the empty string
- SUBROUTINE get_value ( varname , str , retval )
- IMPLICIT NONE
- CHARACTER*(*) :: varname
- CHARACTER*(*) :: str
- CHARACTER*(*) :: retval
- CHARACTER (128) varstr, tstr
- INTEGER i,j,n,varstrn
- LOGICAL nobreak, nobreakouter
- varstr = TRIM(varname)//"="
- varstrn = len(TRIM(varstr))
- n = len(TRIM(str))
- retval = ""
- i = 1
- nobreakouter = .TRUE.
- DO WHILE ( nobreakouter )
- j = 1
- nobreak = .TRUE.
- tstr = ""
- DO WHILE ( nobreak )
- nobreak = .FALSE.
- IF ( i .LE. n ) THEN
- IF (str(i:i) .NE. ',' ) THEN
- tstr(j:j) = str(i:i)
- nobreak = .TRUE.
- ENDIF
- ENDIF
- j = j + 1
- i = i + 1
- ENDDO
- IF ( i .GT. n ) nobreakouter = .FALSE.
- IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
- retval(1:) = TRIM(tstr(varstrn+1:))
- nobreakouter = .FALSE.
- ENDIF
- ENDDO
- RETURN
- END SUBROUTINE get_value
- !--- ioinit
- SUBROUTINE init_module_ext_esmf
- IMPLICIT NONE
- INTEGER :: i
- DO i = 1, int_num_handles
- WRITE( msg,* ) 'init_module_ext_esmf: calling ioesmf_nullify_grid(',i,')'
- CALL wrf_debug ( 5, TRIM(msg) )
- CALL ioesmf_nullify_grid( i )
- ENDDO
- RETURN
- END SUBROUTINE init_module_ext_esmf
- ! allgather for integers, ESMF_style (since ESMF does not do this yet)
- SUBROUTINE GatherIntegerScalars_ESMF( inval, pe, numprocs, outvals )
- INTEGER, INTENT(IN ) :: inval ! input scalar on this task
- INTEGER, INTENT(IN ) :: pe ! task id
- INTEGER, INTENT(IN ) :: numprocs ! number of tasks
- INTEGER, INTENT( OUT) :: outvals(0:numprocs-1) ! gathered output vector
- ! Local declarations
- TYPE(ESMF_VM) :: vm
- INTEGER(ESMF_KIND_I4) :: allSnd(0:numprocs-1)
- INTEGER(ESMF_KIND_I4) :: allRcv(0:numprocs-1)
- INTEGER :: rc
- ! get current ESMF virtual machine for communication
- CALL ESMF_VMGetCurrent(vm, rc=rc)
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_VMGetCurrent', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- allSnd = 0_ESMF_KIND_I4
- allSnd(pe) = inval
- ! Hack due to lack of ESMF_VMAllGather().
- ! 5.2.0r CALL ESMF_VMAllReduce(vm, allSnd, allRcv, numprocs, ESMF_SUM, rc=rc )
- CALL ESMF_VMAllReduce(vm, allSnd, allRcv, numprocs, ESMF_REDUCE_SUM, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_VMAllReduce', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- outvals = allRcv
- END SUBROUTINE GatherIntegerScalars_ESMF
- END MODULE module_ext_esmf
- ! Indexes for non-staggered variables come in at one-less than
- ! domain dimensions, but io_esmf is currently hacked to use full
- ! domain spec, so adjust if not staggered.
- !TODO: remove this hackery once ESMF can support staggered
- !TODO: grids in regional models
- SUBROUTINE ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
- DomainEndFull, PatchEndFull )
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: numdims
- INTEGER, INTENT(IN ) :: DomainEnd(numdims)
- INTEGER, INTENT(IN ) :: PatchEnd(numdims)
- CHARACTER*(*), INTENT(IN ) :: Stagger
- INTEGER, INTENT( OUT) :: DomainEndFull(numdims)
- INTEGER, INTENT( OUT) :: PatchEndFull(numdims)
- LOGICAL, EXTERNAL :: has_char
- DomainEndFull(1:numdims) = DomainEnd(1:numdims)
- IF ( .NOT. has_char( Stagger, 'x' ) ) DomainEndFull(1) = DomainEndFull(1) + 1
- IF ( .NOT. has_char( Stagger, 'y' ) ) DomainEndFull(2) = DomainEndFull(2) + 1
- PatchEndFull(1:numdims) = PatchEnd(1:numdims)
- IF ( .NOT. has_char( Stagger, 'x' ) ) THEN
- IF ( DomainEnd(1) == PatchEnd(1) ) PatchEndFull(1) = DomainEndFull(1)
- ENDIF
- IF ( .NOT. has_char( Stagger, 'y' ) ) THEN
- IF ( DomainEnd(2) == PatchEnd(2) ) PatchEndFull(2) = DomainEndFull(2)
- ENDIF
- END SUBROUTINE ioesmf_endfullhack
- ! Create the ESMF_Grid associated with index DataHandle.
- !TODO: Note that periodicity is not supported by this interface. If
- !TODO: periodicity is needed, pass in via SysDepInfo in the call to
- !TODO: ext_esmf_ioinit().
- !TODO: Note that lat/lon coordinates are not supported by this interface
- !TODO: since general curvilinear coordindates (needed for map projections
- !TODO: used by WRF such as polar stereographic, mercator, lambert conformal)
- !TODO: are not supported by ESMF as of ESMF 2.1.1. Once they are supported,
- !TODO: add them via the "sieve" method used in ../io_mcel/.
- SUBROUTINE ioesmf_create_grid( DataHandle, numdims, &
- MemoryOrder, Stagger, &
- DomainStart, DomainEnd, &
- MemoryStart, MemoryEnd, &
- PatchStart, PatchEnd )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: DataHandle
- INTEGER, INTENT(IN ) :: numdims
- CHARACTER*(*), INTENT(IN ) :: MemoryOrder ! not used yet
- CHARACTER*(*), INTENT(IN ) :: Stagger
- INTEGER, INTENT(IN ) :: DomainStart(numdims), DomainEnd(numdims)
- INTEGER, INTENT(IN ) :: MemoryStart(numdims), MemoryEnd(numdims)
- INTEGER, INTENT(IN ) :: PatchStart(numdims), PatchEnd(numdims)
- INTEGER :: DomainEndFull(numdims)
- INTEGER :: PatchEndFull(numdims)
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid: begin, DataHandle = ', DataHandle
- CALL wrf_debug ( 5, TRIM(msg) )
- ! For now, blindly create a new grid if it does not already exist for
- ! this DataHandle
- !TODO: Note that this approach will result in duplicate ESMF_Grids when
- !TODO: io_esmf is used for input and output. The first ESMF_Grid will
- !TODO: be associated with the input handle and the second will be associated
- !TODO: with the output handle. Fix this if ESMF_Grids are expensive.
- IF ( .NOT. grid( DataHandle )%in_use ) THEN
- IF ( ASSOCIATED( grid( DataHandle )%ptr ) ) THEN
- CALL wrf_error_fatal ( 'ASSERTION ERROR: grid(',DataHandle,') should be NULL' )
- ENDIF
- IF ( numdims /= 2 ) THEN
- CALL wrf_error_fatal ( 'ERROR: only 2D arrays supported so far with io_esmf' )
- ELSE
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid: creating grid(',DataHandle,')%ptr'
- CALL wrf_debug ( 5, TRIM(msg) )
- ALLOCATE( grid( DataHandle )%ptr )
- grid( DataHandle )%in_use = .TRUE.
- ! The non-staggered variables come in at one-less than
- ! domain dimensions, but io_esmf is currently hacked to use full
- ! domain spec, so adjust if not staggered.
- !TODO: remove this hackery once ESMF can support staggered
- !TODO: grids in regional models
- CALL ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
- DomainEndFull, PatchEndFull )
- !TODO: at the moment this is hard-coded for 2D arrays
- !TODO: use MemoryOrder to set these properly!
- !TODO: also, set these once only
- !TODO: maybe even rip this out since it depends on a hack in input_wrf.F ...
- grid( DataHandle )%ide_save = DomainEndFull(1)
- grid( DataHandle )%jde_save = DomainEndFull(2)
- grid( DataHandle )%kde_save = 1
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid: DomainEndFull = ', DomainEndFull
- CALL wrf_debug ( 5, TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid: PatchEndFull = ', PatchEndFull
- CALL wrf_debug ( 5, TRIM(msg) )
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid: Calling ioesmf_create_grid_int()' )
- CALL ioesmf_create_grid_int( grid( DataHandle )%ptr, &
- numdims, &
- DomainStart, DomainEndFull, &
- ! DomainStart, DomainEnd, &
- MemoryStart, MemoryEnd, &
- ! PatchStart, PatchEndFull )
- PatchStart, PatchEnd )
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid: back from ioesmf_create_grid_int()' )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid: done creating grid(',DataHandle,')%ptr'
- CALL wrf_debug ( 5, TRIM(msg) )
- ENDIF
- ENDIF
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid: end'
- CALL wrf_debug ( 5, TRIM(msg) )
- END SUBROUTINE ioesmf_create_grid
- ! Create an ESMF_Grid that matches a WRF decomposition.
- !TODO: Note that periodicity is not supported by this interface. If
- !TODO: periodicity is needed, pass in via SysDepInfo in the call to
- !TODO: ext_esmf_ioinit().
- !TODO: Note that lat/lon coordinates are not supported by this interface
- !TODO: since general curvilinear coordindates (needed for map projections
- !TODO: used by WRF such as polar stereographic, mercator, lambert conformal)
- !TODO: are not supported by ESMF as of ESMF 2.1.1. Once they are supported,
- !TODO: add them via the "sieve" method used in ../io_mcel/.
- !TODO: Note that DomainEnd and PatchEnd must currently include "extra"
- !TODO: points for non-periodic staggered arrays. It may be possible to
- !TODO: remove this hackery once ESMF can support staggered
- !TODO: grids in regional models.
- SUBROUTINE ioesmf_create_grid_int( esmfgrid, numdims, &
- DomainStart, DomainEnd, &
- MemoryStart, MemoryEnd, &
- PatchStart, PatchEnd )
- USE module_ext_esmf
- IMPLICIT NONE
- TYPE(ESMF_Grid), INTENT(INOUT) :: esmfgrid
- INTEGER, INTENT(IN ) :: numdims
- INTEGER, INTENT(IN ) :: DomainStart(numdims), DomainEnd(numdims)
- INTEGER, INTENT(IN ) :: MemoryStart(numdims), MemoryEnd(numdims)
- INTEGER, INTENT(IN ) :: PatchStart(numdims), PatchEnd(numdims)
- ! Local declarations
- INTEGER :: numprocs ! total number of tasks
- INTEGER, ALLOCATABLE :: ipatchStarts(:), jpatchStarts(:)
- INTEGER :: numprocsX ! number of tasks in "i" dimension
- INTEGER :: numprocsY ! number of tasks in "j" dimension
- INTEGER, ALLOCATABLE :: permuteTasks(:)
- INTEGER :: globalXcount ! staggered domain count in "i" dimension
- INTEGER :: globalYcount ! staggered domain count in "j" dimension
- INTEGER :: myXstart ! task-local start in "i" dimension
- INTEGER :: myYstart ! task-local start in "j" dimension
- INTEGER :: myXend ! staggered task-local end in "i" dimension
- INTEGER :: myYend ! staggered task-local end in "j" dimension
- INTEGER, ALLOCATABLE :: allXStart(:)
- INTEGER, ALLOCATABLE :: allXCount(:)
- INTEGER, ALLOCATABLE :: dimXCount(:)
- INTEGER, ALLOCATABLE :: allYStart(:)
- INTEGER, ALLOCATABLE :: allYCount(:)
- INTEGER, ALLOCATABLE :: dimYCount(:)
- REAL(ESMF_KIND_R8), ALLOCATABLE :: coordX(:)
- REAL(ESMF_KIND_R8), ALLOCATABLE :: coordY(:)
- INTEGER, ALLOCATABLE :: cellCounts(:,:)
- INTEGER, ALLOCATABLE :: globalStarts(:,:)
- INTEGER :: rc, debug_level
- INTEGER :: myXcount ! task-local count in "i" dimension
- INTEGER :: myYcount ! task-local count in "j" dimension
- INTEGER :: globalCellCounts(2)
- INTEGER :: numprocsXY(2)
- INTEGER :: myPE, i, j, pe, is, ie, js, je, is_min, js_min, ie_max, je_max
- INTEGER :: ips, ipe, jps, jpe, ids, ide, jds, jde
- TYPE(ESMF_VM) :: vm
- TYPE(ESMF_DELayout) :: taskLayout
- REAL(ESMF_KIND_R8), DIMENSION(:), POINTER :: coordX2d, coordY2d
- INTEGER, DIMENSION(3) :: ubnd, lbnd
- CHARACTER (32) :: gridname
- INTEGER, SAVE :: gridID = 0
- CALL get_wrf_debug_level( debug_level )
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: begin...' )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numdims = ',numdims
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: DomainStart = ',DomainStart(1:numdims)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: DomainEnd = ',DomainEnd(1:numdims)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: MemoryStart = ',MemoryStart(1:numdims)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: MemoryEnd = ',MemoryEnd(1:numdims)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: PatchStart = ',PatchStart(1:numdims)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: PatchEnd = ',PatchEnd(1:numdims)
- CALL wrf_debug ( 5 , TRIM(msg) )
- ! First, determine number of tasks and number of tasks in each decomposed
- ! dimension (ESMF 2.2.0 is restricted to simple task layouts)
- ! get current ESMF virtual machine and inquire...
- CALL ESMF_VMGetCurrent(vm, rc=rc)
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_VMGetCurrent', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- !TODO: Note (PET==MPI process) assumption here. This is OK in ESMF
- !TODO: 2.2.0 but may change in a future ESMF release. If so, we will
- !TODO: need another way to do this. May want to grab mpiCommunicator
- !TODO: instead and ask it directly for number of MPI tasks. Unless this
- !TODO: is a serial run...
- CALL ESMF_VMGet(vm, petCount=numprocs, localPet=myPE, rc=rc)
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_VMGet', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- ALLOCATE( ipatchStarts(0:numprocs-1), jpatchStarts(0:numprocs-1) )
- CALL GatherIntegerScalars_ESMF(PatchStart(1), myPE, numprocs, ipatchStarts)
- CALL GatherIntegerScalars_ESMF(PatchStart(2), myPE, numprocs, jpatchStarts)
- numprocsX = 0
- numprocsY = 0
- DO pe = 0, numprocs-1
- IF ( PatchStart(1) == ipatchStarts(pe) ) THEN
- numprocsY = numprocsY + 1
- ENDIF
- IF ( PatchStart(2) == jpatchStarts(pe) ) THEN
- numprocsX = numprocsX + 1
- ENDIF
- ENDDO
- DEALLOCATE( ipatchStarts, jpatchStarts )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numprocsX = ',numprocsX
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numprocsY = ',numprocsY
- CALL wrf_debug ( 5 , TRIM(msg) )
- ! sanity check
- IF ( numprocs /= numprocsX*numprocsY ) THEN
- CALL wrf_error_fatal ( 'ASSERTION FAILED: numprocs /= numprocsX*numprocsY' )
- ENDIF
- ! Next, create ESMF_DELayout
- numprocsXY = (/ numprocsX, numprocsY /)
- !TODO: 1-to-1 DE to PET mapping is assumed below...
- ALLOCATE( permuteTasks(0:numprocs-1) )
- pe = 0
- DO j = 0, numprocsY-1
- DO i = 0, numprocsX-1
- ! NOTE: seems to work both ways...
- ! (/ 0 2 1 3 /)
- ! permuteTasks(pe) = (i*numprocsY) + j
- ! (/ 0 1 2 3 /)
- permuteTasks(pe) = pe
- pe = pe + 1
- ENDDO
- ENDDO
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numprocsXY = ',numprocsXY
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: permuteTasks = ',permuteTasks
- CALL wrf_debug ( 5 , TRIM(msg) )
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: calling ESMF_DELayoutCreate' )
- taskLayout = ESMF_DELayoutCreate( vm, numprocsXY, petList=permuteTasks, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_DELayoutCreate', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: back from ESMF_DELayoutCreate' )
- DEALLOCATE( permuteTasks )
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: calling ESMF_DELayoutPrint 1' )
- IF ( 5 .LE. debug_level ) THEN
- CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
- ENDIF
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: back from ESMF_DELayoutPrint 1' )
- ! Compute the dimensions for the ESMF grid, using WRF's non-staggered dimensions
- ! This is as of ESMF v3, JM 20080715
- ! the [ij][dp][se] bits are for convenience...
- ids = DomainStart(1); ide = DomainEnd(1);
- jds = DomainStart(2); jde = DomainEnd(2);
- ips = PatchStart(1); ipe = PatchEnd(1);
- jps = PatchStart(2); jpe = PatchEnd(2);
- globalXcount = ide - ids ! in other words, the number of points from ids to ide-1 inclusive
- globalYcount = jde - jds ! in other words, the number of points from jds to jde-1 inclusive
- ! task-local numbers of points in patch for staggered arrays
- myXstart = ips
- myYstart = jps
- myXend = MIN(ipe,ide-1)
- myYend = MIN(jpe,jde-1)
- myXcount = myXend - myXstart + 1
- myYcount = myYend - myYstart + 1
- ! gather task-local information on all tasks since
- ! ESMF_GridDistribute[Block] interface require global knowledge to set up
- ! decompositions
- ! Recall that coordX and coordY are coordinates of *vertices*, not cell centers.
- ! Thus they must be 1 bigger than the number of cells.
- ALLOCATE( allXStart(0:numprocs-1), allXCount(0:numprocs-1), &
- allYStart(0:numprocs-1), allYCount(0:numprocs-1), &
- dimXCount(0:numprocsX-1), dimYCount(0:numprocsY-1), &
- coordX(globalXcount+1), coordY(globalYcount+1) )
- CALL GatherIntegerScalars_ESMF(myXcount, myPE, numprocs, allXCount)
- CALL GatherIntegerScalars_ESMF(myXstart, myPE, numprocs, allXStart)
- CALL GatherIntegerScalars_ESMF(myYcount, myPE, numprocs, allYCount)
- CALL GatherIntegerScalars_ESMF(myYstart, myPE, numprocs, allYStart)
- !TODO: ESMF 2.x does not support mercator, polar-stereographic, or
- !TODO: lambert-conformal projections. Therefore, we're using fake
- !TODO: coordinates here. This means that WRF will either have to
- !TODO: couple to models that run on the same coorindate such that
- !TODO: grid points are co-located or something else will have to
- !TODO: perform the inter-grid interpolation computations. Replace
- !TODO: this once ESMF is upgraded to support the above map
- !TODO: projections (via general curvilinear coordinates).
- CALL wrf_message( 'WARNING: Using artificial coordinates for ESMF coupling.' )
- CALL wrf_message( 'WARNING: ESMF coupling interpolation will be incorrect' )
- CALL wrf_message( 'WARNING: unless grid points in the coupled components' )
- CALL wrf_message( 'WARNING: are co-located. This limitation will be removed' )
- CALL wrf_message( 'WARNING: once ESMF coupling supports generalized' )
- CALL wrf_message( 'WARNING: curvilinear coordintates needed to represent' )
- CALL wrf_message( 'WARNING: common map projections used by WRF and other' )
- CALL wrf_message( 'WARNING: regional models.' )
- ! Note that ESMF defines coordinates at *vertices*
- coordX(1) = 0.0
- DO i = 2, SIZE(coordX)
- coordX(i) = coordX(i-1) + 1.0
- ENDDO
- coordY(1) = 0.0
- DO j = 2, SIZE(coordY)
- coordY(j) = coordY(j-1) + 1.0
- ENDDO
- ! Create an ESMF_Grid
- ! For now we create only a 2D grid suitable for simple coupling of 2D
- ! surface fields. Later, create and subset one or more 3D grids.
- !TODO: Pass staggering info into this routine once ESMF can support staggered
- !TODO: grids. For now, it is hard-coded for WRF-ARW.
- gridID = gridID + 1
- WRITE ( gridname,'(a,i0)' ) 'WRF_grid_', gridID
- CALL wrf_debug ( 5 , 'DEBUG WRF: Calling ESMF_GridCreate' )
- WRITE( msg,* ) 'DEBUG WRF: SIZE(coordX) = ', SIZE(coordX)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG WRF: SIZE(coordY) = ', SIZE(coordY)
- CALL wrf_debug ( 5 , TRIM(msg) )
- DO i = 1, SIZE(coordX)
- WRITE( msg,* ) 'DEBUG WRF: coord1(',i,') = ', coordX(i)
- CALL wrf_debug ( 5 , TRIM(msg) )
- ENDDO
- DO j = 1, SIZE(coordY)
- WRITE( msg,* ) 'DEBUG WRF: coord2(',j,') = ', coordY(j)
- CALL wrf_debug ( 5 , TRIM(msg) )
- ENDDO
- !WRITE( msg,* ) 'DEBUG WRF: horzstagger = ', ESMF_GRID_HORZ_STAGGER_C_SW
- !CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG WRF: name = ', TRIM(gridname)
- CALL wrf_debug ( 5 , TRIM(msg) )
- ! distribute the ESMF_Grid
- ! ignore repeated values
- is_min = MINVAL(allXStart)
- js_min = MINVAL(allYStart)
- i = 0
- j = 0
- WRITE( msg,* ) 'DEBUG: is_min = ',is_min,' allXStart = ',allXStart
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: js_min = ',js_min,' allYStart = ',allYStart
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: allXCount = ',allXCount
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: allYCount = ',allYCount
- CALL wrf_debug ( 5 , TRIM(msg) )
- DO pe = 0, numprocs-1
- IF (allXStart(pe) == is_min) THEN
- IF (j >= numprocsY) THEN
- WRITE( msg,* ) 'ASSERTION FAILED in ESMF_GridCreate', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- WRITE( msg,* ) 'DEBUG: dimYCount(',j,') == allYCount(',pe,')'
- CALL wrf_debug ( 5 , TRIM(msg) )
- dimYCount(j) = allYCount(pe)
- j = j + 1
- ENDIF
- IF (allYStart(pe) == js_min) THEN
- IF (i >= numprocsX) THEN
- WRITE( msg,* ) 'ASSERTION FAILED in ESMF_GridCreate', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- WRITE( msg,* ) 'DEBUG: dimXCount(',i,') == allXCount(',pe,')'
- CALL wrf_debug ( 5 , TRIM(msg) )
- dimXCount(i) = allXCount(pe)
- i = i + 1
- ENDIF
- ENDDO
- WRITE( msg,* ) 'DEBUG: i = ',i,' dimXCount = ',dimXCount
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: j = ',j,' dimYCount = ',dimYCount
- CALL wrf_debug ( 5 , TRIM(msg) )
- #if 0
- esmfgrid = ESMF_GridCreateHorzXY( &
- coord1=coordX, coord2=coordY, &
- horzstagger=ESMF_GRID_HORZ_STAGGER_C_SW, &
- !TODO: use this for 3D Grids once it is stable
- ! coordorder=ESMF_COORD_ORDER_XZY, &
- name=TRIM(gridname), rc=rc )
- #else
- ! based on example in 3.1 ref man sec 23.2.5, Creating an Irregularly
- ! Distributed Rectilinear Grid with a Non-Distributed Vertical Dimension
- !esmfgrid = ESMF_GridCreateShapeTile( &
- !write(0,*)'calling ESMF_GridCreateShapeTile for grid named ',trim(gridname)
- !write(0,*)'calling ESMF_GridCreateShapeTile dimXCount ',dimXCount
- !write(0,*)'calling ESMF_GridCreateShapeTile dimYCount ',dimYCount
- ! 5.2.0r esmfgrid = ESMF_GridCreateShapeTile( &
- esmfgrid = ESMF_GridCreate( &
- countsPerDEDim1=dimXCount , &
- countsPerDEDim2=dimYcount , &
- coordDep1=(/1/) , &
- coordDep2=(/2/) , &
- indexflag=ESMF_INDEX_GLOBAL, & ! use global indices
- name=TRIM(gridname), &
- rc = rc )
- CALL ESMF_GridAddCoord(esmfgrid, &
- staggerloc=ESMF_STAGGERLOC_CENTER, &
- rc=rc)
- CALL ESMF_GridGetCoord(esmfgrid,coordDim=1,localDE=0, &
- staggerloc=ESMF_STAGGERLOC_CENTER, &
- computationalLBound=lbnd,computationalUBound=ubnd, &
- farrayptr=coordX2d, &
- rc=rc)
- DO i=lbnd(1),ubnd(1)
- coordX2d(i) = (i-1)*1.0
- ENDDO
- CALL ESMF_GridGetCoord(esmfgrid,coordDim=2,localDE=0, &
- staggerloc=ESMF_STAGGERLOC_CENTER, &
- computationalLBound=lbnd,computationalUBound=ubnd, &
- farrayptr=coordY2d, &
- rc=rc)
- DO i=lbnd(1),ubnd(1)
- coordY2d(i) = (i-1)*1.0
- ENDDO
-
-
- #endif
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridCreate', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- CALL wrf_debug ( 5 , 'DEBUG WRF: back OK from ESMF_GridCreate' )
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: calling ESMF_DELayoutPrint 2' )
- IF ( 5 .LE. debug_level ) THEN
- CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
- ENDIF
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: back from ESMF_DELayoutPrint 2' )
- #if 0
- CALL ESMF_GridDistribute( esmfgrid, &
- delayout=taskLayout, &
- countsPerDEDim1=dimXCount, &
- countsPerDEDim2=dimYCount, &
- rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridDistribute ', &
- __FILE__ , &
- ', line ', &
- __LINE__ , &
- ', error code = ',rc
- CALL wrf_error_fatal ( msg )
- ENDIF
- #endif
- CALL wrf_debug ( 5 , 'DEBUG WRF: Calling ESMF_GridValidate()' )
- CALL ESMF_GridValidate( esmfgrid, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridValidate ', &
- __FILE__ , &
- ', line ', &
- __LINE__ , &
- ', error code = ',rc
- CALL wrf_error_fatal ( msg )
- ENDIF
- CALL wrf_debug ( 5 , 'DEBUG WRF: back OK from ESMF_GridValidate()' )
- DEALLOCATE( allXStart, allXCount, allYStart, allYCount, &
- dimXCount, dimYCount, coordX, coordY )
- #if 0
- ! Print out the ESMF decomposition info for debug comparison with WRF
- ! decomposition info.
- ALLOCATE( cellCounts(0:numprocs-1,2), globalStarts(0:numprocs-1,2) )
- ! extract information about staggered grids for debugging
- CALL ESMF_GridGet( esmfgrid, &
- horzrelloc=ESMF_CELL_WFACE, &
- globalStartPerDEPerDim=globalStarts, &
- cellCountPerDEPerDim=cellCounts, &
- globalCellCountPerDim=globalCellCounts, &
- rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridGet', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- ! note that global indices in ESMF_Grid always start at zero
- WRITE( msg,* ) 'DEBUG: ESMF staggered ips = ',1+globalStarts(myPE,1)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: ESMF staggered ipe = ',1+globalStarts(myPE,1) + cellCounts(myPE,1) - 1
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: ESMF staggered i count = ', cellCounts(myPE,1)
- CALL wrf_debug ( 5 , TRIM(msg) )
- CALL ESMF_GridGet( esmfgrid, &
- horzrelloc=ESMF_CELL_SFACE, &
- globalStartPerDEPerDim=globalStarts, &
- cellCountPerDEPerDim=cellCounts, &
- globalCellCountPerDim=globalCellCounts, &
- rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridGet', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- ! note that global indices in ESMF_Grid always start at zero
- WRITE( msg,* ) 'DEBUG: ESMF staggered jps = ',1+globalStarts(myPE,2)
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: ESMF staggered jpe = ',1+globalStarts(myPE,2) + cellCounts(myPE,2) - 1
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG: ESMF staggered j count = ', cellCounts(myPE,2)
- CALL wrf_debug ( 5 , TRIM(msg) )
- DEALLOCATE( cellCounts, globalStarts )
- CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int: print esmfgrid BEGIN...' )
- IF ( 100 .LE. debug_level ) THEN
- CALL ESMF_GridPrint( esmfgrid, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridPrint', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- ENDIF
- CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int: print esmfgrid END' )
- #endif
- CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: returning...' )
- END SUBROUTINE ioesmf_create_grid_int
- ! Destroy the ESMF_Grid associated with index DataHandle.
- ! grid( DataHandle )%ptr is DEALLOCATED (NULLIFIED)
- SUBROUTINE ioesmf_destroy_grid( DataHandle )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: DataHandle
- ! Local declarations
- INTEGER :: id, rc
- TYPE(ESMF_DELayout) :: taskLayout
- LOGICAL :: noneLeft
- IF ( grid( DataHandle )%in_use ) THEN
- #if 0
- WRITE( msg,* ) 'DEBUG: ioesmf_destroy_grid( ',DataHandle,' ) begin...'
- CALL wrf_debug ( 5 , TRIM(msg) )
- CALL ESMF_GridGet( grid( DataHandle )%ptr, delayout=taskLayout, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridGet', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- ! I "know" I created this... (not really, but ESMF cannot tell me!)
- CALL ESMF_DELayoutDestroy( taskLayout, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_DELayoutDestroy', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- #endif
- CALL ESMF_GridDestroy( grid( DataHandle )%ptr, rc=rc )
- IF ( rc /= ESMF_SUCCESS ) THEN
- WRITE( msg,* ) 'Error in ESMF_GridDestroy', &
- __FILE__ , &
- ', line', &
- __LINE__
- CALL wrf_error_fatal ( msg )
- ENDIF
- DEALLOCATE( grid( DataHandle )%ptr )
- CALL ioesmf_nullify_grid( DataHandle )
- WRITE( msg,* ) 'DEBUG: ioesmf_destroy_grid( ',DataHandle,' ) end'
- CALL wrf_debug ( 5 , TRIM(msg) )
- ENDIF
- END SUBROUTINE ioesmf_destroy_grid
- ! Nullify the grid_ptr associated with index DataHandle.
- ! grid( DataHandle )%ptr must not be associated
- ! DataHandle must be in a valid range
- SUBROUTINE ioesmf_nullify_grid( DataHandle )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: DataHandle
- NULLIFY( grid( DataHandle )%ptr )
- grid( DataHandle )%in_use = .FALSE.
- grid( DataHandle )%ide_save = 0
- grid( DataHandle )%jde_save = 0
- grid( DataHandle )%kde_save = 0
- END SUBROUTINE ioesmf_nullify_grid
- !TODO: use generic explicit interfaces and remove duplication
- !TODO: use cpp to remove duplication
- SUBROUTINE ioesmf_extract_data_real( data_esmf_real, Field, &
- ips, ipe, jps, jpe, kps, kpe, &
- ims, ime, jms, jme, kms, kme )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
- INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
- REAL(ESMF_KIND_R4), INTENT(IN ) :: data_esmf_real( ips:ipe, jps:jpe )
- REAL, INTENT( OUT) :: Field( ims:ime, jms:jme, kms:kme )
- Field( ips:ipe, jps:jpe, kms ) = data_esmf_real( ips:ipe, jps:jpe )
- END SUBROUTINE ioesmf_extract_data_real
- !TODO: use cpp to remove duplication
- SUBROUTINE ioesmf_extract_data_int( data_esmf_int, Field, &
- ips, ipe, jps, jpe, kps, kpe, &
- ims, ime, jms, jme, kms, kme )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
- INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
- INTEGER(ESMF_KIND_I4), INTENT(IN ) :: data_esmf_int( ips:ipe, jps:jpe )
- INTEGER, INTENT( OUT) :: Field( ims:ime, jms:jme, kms:kme )
- Field( ips:ipe, jps:jpe, kms ) = data_esmf_int( ips:ipe, jps:jpe )
- END SUBROUTINE ioesmf_extract_data_int
- !TODO: use cpp to remove duplication
- SUBROUTINE ioesmf_insert_data_real( Field, data_esmf_real, &
- ips, ipe, jps, jpe, kps, kpe, &
- ims, ime, jms, jme, kms, kme )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
- INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
- REAL, INTENT(IN ) :: Field( ims:ime, jms:jme, kms:kme )
- REAL(ESMF_KIND_R4), INTENT( OUT) :: data_esmf_real( ips:ipe, jps:jpe )
- !TODO: Remove this hack once we no longer have to store non-staggered
- !TODO: arrays in space dimensioned for staggered arrays.
- data_esmf_real = 0.0_ESMF_KIND_R4
- data_esmf_real( ips:ipe, jps:jpe ) = Field( ips:ipe, jps:jpe, kms )
- END SUBROUTINE ioesmf_insert_data_real
- !TODO: use cpp to remove duplication
- SUBROUTINE ioesmf_insert_data_int( Field, data_esmf_int, &
- ips, ipe, jps, jpe, kps, kpe, &
- ims, ime, jms, jme, kms, kme )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
- INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
- INTEGER, INTENT(IN ) :: Field( ims:ime, jms:jme, kms:kme )
- INTEGER(ESMF_KIND_I4), INTENT( OUT) :: data_esmf_int( ips:ipe, jps:jpe )
- !TODO: Remove this hack once we no longer have to store non-staggered
- !TODO: arrays in space dimensioned for staggered arrays.
- data_esmf_int = 0.0_ESMF_KIND_I4
- data_esmf_int( ips:ipe, jps:jpe ) = Field( ips:ipe, jps:jpe, kms )
- END SUBROUTINE ioesmf_insert_data_int
- !--------------
- SUBROUTINE ext_esmf_ioinit( SysDepInfo, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- CHARACTER*(*), INTENT(IN) :: SysDepInfo
- INTEGER Status
- CALL init_module_ext_esmf
- Status = 0
- END SUBROUTINE ext_esmf_ioinit
- !--- open_for_read
- SUBROUTINE ext_esmf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
- DataHandle , Status )
- USE module_ext_esmf
- IMPLICIT NONE
- CHARACTER*(*) :: FileName
- INTEGER , INTENT(IN) :: Comm_compute , Comm_io
- CHARACTER*(*) :: SysDepInfo
- INTEGER , INTENT(OUT) :: DataHandle
- INTEGER , INTENT(OUT) :: Status
- CALL wrf_debug(1,'ext_esmf_open_for_read not supported yet')
- Status = WRF_WARN_NOTSUPPORTED
- RETURN
- END SUBROUTINE ext_esmf_open_for_read
- !--- inquire_opened
- SUBROUTINE ext_esmf_inquire_opened ( DataHandle, FileName , FileStatus, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: FileName
- INTEGER , INTENT(OUT) :: FileStatus
- INTEGER , INTENT(OUT) :: Status
- Status = 0
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: begin, DataHandle = ', DataHandle
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: int_valid_handle(',DataHandle,') = ', &
- int_valid_handle( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: int_handle_in_use(',DataHandle,') = ', &
- int_handle_in_use( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: opened_for_read(',DataHandle,') = ', &
- opened_for_read( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: okay_to_read(',DataHandle,') = ', &
- okay_to_read( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: opened_for_write(',DataHandle,') = ', &
- opened_for_write( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: okay_to_write(',DataHandle,') = ', &
- okay_to_write( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- !TODO: need to cache file name and match with FileName argument and return
- !TODO: FileStatus = WRF_FILE_NOT_OPENED if they do not match
- FileStatus = WRF_FILE_NOT_OPENED
- IF ( int_valid_handle( DataHandle ) ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- IF ( opened_for_read ( DataHandle ) ) THEN
- IF ( okay_to_read( DataHandle ) ) THEN
- FileStatus = WRF_FILE_OPENED_FOR_READ
- ELSE
- FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
- ENDIF
- ELSE IF ( opened_for_write( DataHandle ) ) THEN
- IF ( okay_to_write( DataHandle ) ) THEN
- FileStatus = WRF_FILE_OPENED_FOR_WRITE
- ELSE
- FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
- ENDIF
- ELSE
- FileStatus = WRF_FILE_NOT_OPENED
- ENDIF
- ENDIF
- WRITE( msg,* ) 'ERROR ext_esmf_inquire_opened: file handle ',DataHandle,' is invalid'
- CALL wrf_error_fatal ( TRIM(msg) )
- ENDIF
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: end, FileStatus = ', FileStatus
- CALL wrf_debug ( 5 , TRIM(msg) )
- Status = 0
-
- RETURN
- END SUBROUTINE ext_esmf_inquire_opened
- !--- inquire_filename
- SUBROUTINE ext_esmf_inquire_filename ( DataHandle, FileName , FileStatus, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: FileName
- INTEGER , INTENT(OUT) :: FileStatus
- INTEGER , INTENT(OUT) :: Status
- CHARACTER *80 SysDepInfo
- Status = 0
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: begin, DataHandle = ', DataHandle
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: int_valid_handle(',DataHandle,') = ', &
- int_valid_handle( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: int_handle_in_use(',DataHandle,') = ', &
- int_handle_in_use( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: opened_for_read(',DataHandle,') = ', &
- opened_for_read( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: okay_to_read(',DataHandle,') = ', &
- okay_to_read( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: opened_for_write(',DataHandle,') = ', &
- opened_for_write( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: okay_to_write(',DataHandle,') = ', &
- okay_to_write( DataHandle )
- CALL wrf_debug ( 5 , TRIM(msg) )
- !TODO: need to cache file name and return via FileName argument
- FileStatus = WRF_FILE_NOT_OPENED
- IF ( int_valid_handle( DataHandle ) ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- IF ( opened_for_read ( DataHandle ) ) THEN
- IF ( okay_to_read( DataHandle ) ) THEN
- FileStatus = WRF_FILE_OPENED_FOR_READ
- ELSE
- FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
- ENDIF
- ELSE IF ( opened_for_write( DataHandle ) ) THEN
- IF ( okay_to_write( DataHandle ) ) THEN
- FileStatus = WRF_FILE_OPENED_FOR_WRITE
- ELSE
- FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
- ENDIF
- ELSE
- FileStatus = WRF_FILE_NOT_OPENED
- ENDIF
- ENDIF
- WRITE( msg,* ) 'ERROR ext_esmf_inquire_filename: file handle ',DataHandle,' is invalid'
- CALL wrf_error_fatal ( TRIM(msg) )
- ENDIF
- WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: end, FileStatus = ', FileStatus
- CALL wrf_debug ( 5 , TRIM(msg) )
- Status = 0
- RETURN
- END SUBROUTINE ext_esmf_inquire_filename
- !--- sync
- SUBROUTINE ext_esmf_iosync ( DataHandle, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- INTEGER , INTENT(OUT) :: Status
- Status = 0
- RETURN
- END SUBROUTINE ext_esmf_iosync
- !--- close
- SUBROUTINE ext_esmf_ioclose ( DataHandle, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER DataHandle, Status
- ! locals
- TYPE state_ptr
- TYPE(ESMF_State), POINTER :: stateptr
- END TYPE state_ptr
- TYPE(state_ptr) :: states(2)
- TYPE(ESMF_State), POINTER :: state
- INTEGER :: numItems, numFields, i, istate
- TYPE(ESMF_StateItem_Flag), ALLOCATABLE :: itemTypes(:)
- TYPE(ESMF_Field) :: tmpField
- REAL, POINTER :: tmp_ptr(:,:)
- CHARACTER (len=ESMF_MAXSTR), ALLOCATABLE :: itemNames(:)
- CHARACTER (len=ESMF_MAXSTR) :: str
- INTEGER :: rc
- ! TODO: The code below hangs with this error message:
- ! TODO: "ext_esmf_ioclose: ESMF_FieldGetDataPointer( LANDMASK) failed"
- ! TODO: Fix this so ESMF objects actually get destroyed to avoid memory
- ! TODO: leaks.
- CALL wrf_debug( 5, 'ext_esmf_ioclose: WARNING: not destroying ESMF objects' )
- #if 0
- !TODO: Need to upgrade this to use nested ESMF_States if we want support
- !TODO: more than one auxin and one auxhist stream for ESMF.
- IF ( int_valid_handle (DataHandle) ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- ! Iterate through importState *and* exportState, find each ESMF_Field,
- ! extract its data pointer and deallocate it, then destroy the
- ! ESMF_Field.
- CALL ESMF_ImportStateGetCurrent(states(1)%stateptr, rc)
- IF ( rc /= ESMF_SUCCESS ) THEN
- CALL wrf_error_fatal( 'ext_esmf_ioclose: ESMF_ImportStateGetCurrent failed' )
- ENDIF
- CALL ESMF_ExportStateGetCurrent(states(2)%stateptr, rc)
- IF ( rc /= ESMF_SUCCESS ) THEN
- CALL wrf_error_fatal( 'ext_esmf_ioclose: ESMF_ExportStateGetCurrent failed' )
- ENDIF
- DO istate=1, 2
- state => states(istate)%stateptr ! all this to avoid assignment (@#$%)
- ! Since there are no convenient iterators for ESMF_State (@#$%),
- ! write a lot of code...
- ! Figure out how many items are in the ESMF_State
- CALL ESMF_StateGet(state, itemCount=numItems, rc=rc)
- IF ( rc /= ESMF_SUCCESS) THEN
- CALL wrf_error_fatal ( 'ext_esmf_ioclose: ESMF_StateGet(numItems) failed' )
- ENDIF
- ! allocate an array to hold the types of all items
- ALLOCATE( itemTypes(numItems) )
- ! allocate an array to hold the names of all items
- ALLOCATE( itemNames(numItems) )
- ! get the item types and names
- !5.2.0r CALL ESMF_StateGet(state, stateitemtypeList=itemTypes, &
- CALL ESMF_StateGet(state, itemtypeList=itemTypes, &
- itemNameList=itemNames, rc=rc)
- IF ( rc /= ESMF_SUCCESS) THEN
- WRITE(str,*) 'ext_esmf_ioclose: ESMF_StateGet itemTypes failed with rc = ', rc
- CALL wrf_error_fatal ( str )
- ENDIF
- ! count how many items are ESMF_Fields
- numFields = 0
- DO i=1,numItems
- IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN
- numFields = numFields + 1
- ENDIF
- ENDDO
- IF ( numFields > 0) THEN
- ! finally, extract nested ESMF_Fields by name, if there are any
- ! (should be able to do this by index at least -- @#%$)
- DO i=1,numItems
- IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN
- CALL ESMF_StateGetField( state, TRIM(itemNames(i)), &
- tmpField, rc=rc )
- IF ( rc /= ESMF_SUCCESS) THEN
- WRITE(str,*) 'ext_esmf_ioclose: ESMF_StateGetField(',TRIM(itemNames(i)),') failed'
- CALL wrf_error_fatal ( str )
- ENDIF
- ! destroy pointer in field
- CALL ESMF_FieldGetDataPointer( tmpField, tmp_ptr, rc=rc )
- IF (rc /= ESMF_SUCCESS) THEN
- WRITE( str , * ) &
- 'ext_esmf_ioclose: ESMF_FieldGetDataPointer( ', &
- TRIM(itemNames(i)),') failed'
- CALL wrf_error_fatal ( TRIM(str) )
- ENDIF
- DEALLOCATE( tmp_ptr )
- ! destroy field
- CALL ESMF_FieldDestroy( tmpField, rc=rc )
- IF (rc /= ESMF_SUCCESS) THEN
- WRITE( str , * ) &
- 'ext_esmf_ioclose: ESMF_FieldDestroy( ', &
- TRIM(itemNames(i)),') failed'
- CALL wrf_error_fatal ( TRIM(str) )
- ENDIF
- ENDIF
- ENDDO
- ENDIF
- ! deallocate locals
- DEALLOCATE( itemTypes )
- DEALLOCATE( itemNames )
- ENDDO
- ! destroy ESMF_Grid associated with DataHandle
- CALL ioesmf_destroy_grid( DataHandle )
- ENDIF
- ENDIF
- #endif
- Status = 0
- RETURN
- END SUBROUTINE ext_esmf_ioclose
- !--- ioexit
- SUBROUTINE ext_esmf_ioexit( Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER , INTENT(OUT) :: Status
- INTEGER :: i
- Status = 0
- ! TODO: The code below causes ext_ncd_ioclose() to fail in the
- ! TODO: SST component for reasons as-yet unknown.
- ! TODO: Fix this so ESMF objects actually get destroyed to avoid memory
- ! TODO: leaks.
- CALL wrf_debug( 5, 'ext_esmf_ioexit: WARNING: not destroying ESMF objects' )
- #if 0
- DO i = 1, int_num_handles
- ! close any remaining open DataHandles
- CALL ext_esmf_ioclose ( i, Status )
- ! destroy ESMF_Grid for this DataHandle
- CALL ioesmf_destroy_grid( i )
- ENDDO
- CALL wrf_debug ( 5 , &
- 'ext_esmf_ioexit: DEBUG: done cleaning up ESMF objects' )
- #endif
- RETURN
- END SUBROUTINE ext_esmf_ioexit
- !--- get_next_time
- SUBROUTINE ext_esmf_get_next_time ( DataHandle, DateStr, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: DateStr
- INTEGER , INTENT(OUT) :: Status
- IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
- CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_next_time: invalid data handle" )
- ENDIF
- IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
- CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_next_time: DataHandle not opened" )
- ENDIF
- CALL wrf_debug(1, "ext_esmf_get_next_time() not supported yet")
- Status = WRF_WARN_NOTSUPPORTED
- RETURN
- END SUBROUTINE ext_esmf_get_next_time
- !--- set_time
- SUBROUTINE ext_esmf_set_time ( DataHandle, DateStr, Status )
- USE module_ext_esmf
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: DateStr
- INTEGER , INTENT(OUT) :: Status
- CALL wrf_debug(1, "ext_esmf_set_time() not supported yet")
- Status = WRF_WARN_NOTSUPPORTED
- RETURN
- END SUBROUTINE ext_esmf_set_time
- !--- get_var_info
- SUBROUTINE ext_esmf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
- DomainStart , DomainEnd , WrfType, Status )
- USE module_ext_esmf
- IMPLICIT NON…
Large files files are truncated, but you can click here to view the full file