!--- read_field
SUBROUTINE ext_mcel_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
DomainDesc , MemoryOrder , Stagger , DimNames , &
DomainStart , DomainEnd , &
MemoryStart , MemoryEnd , &
PatchStart , PatchEnd , &
Status )
USE module_ext_mcel
IMPLICIT NONE
INTEGER , INTENT(IN) :: DataHandle
CHARACTER*(*) :: DateStr
CHARACTER*(*) :: VarName
integer ,intent(inout) :: FieldType
integer ,intent(inout) :: Comm
integer ,intent(inout) :: IOComm
integer ,intent(inout) :: DomainDesc
character*(*) ,intent(inout) :: MemoryOrder
character*(*) ,intent(inout) :: Stagger
character*(*) , dimension (*) ,intent(inout) :: DimNames
integer ,dimension(*) ,intent(inout) :: DomainStart, DomainEnd
integer ,dimension(*) ,intent(inout) :: MemoryStart, MemoryEnd
integer ,dimension(*) ,intent(inout) :: PatchStart, PatchEnd
integer ,intent(out) :: Status
!local
INTEGER :: locDataHandle
CHARACTER*132 :: locDateStr
CHARACTER*132 :: locVarName
integer :: locFieldType
integer :: locComm
integer :: locIOComm
integer :: locDomainDesc
character*132 :: locMemoryOrder
character*132 :: locStagger
character*132 , dimension (3) :: locDimNames
integer ,dimension(3) :: locDomainStart, locDomainEnd
integer ,dimension(3) :: locMemoryStart, locMemoryEnd
integer ,dimension(3) :: locPatchStart, locPatchEnd
real, allocatable, dimension(:,:) :: temp
doubleprecision, allocatable, dimension(:,:) :: dtemp
integer gSize(2)
INTEGER, EXTERNAL :: cast_to_int
integer myproc
character*132 mess
integer ips,ipe,jps,jpe
integer ims,ime,jms,jme
integer idex,ierr,i,j
integer ii,jj,kk,myrank,ierr, mcel_type
real*8 data_time
character*14 timestr
! REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
! MemoryStart(2):MemoryEnd(2), &
! MemoryStart(3):MemoryEnd(3) ) :: Field
REAL, DIMENSION(*) :: Field
INTEGER inttypesize, realtypesize, istat, code
IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_read_field: invalid data handle" )
ENDIF
IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_read_field: DataHandle not opened" )
ENDIF
ips = PatchStart(1) ; ipe = PatchEnd(1)
jps = PatchStart(2) ; jpe = PatchEnd(2)
ims = MemoryStart(1) ; ime = MemoryEnd(1)
jms = MemoryStart(2) ; jme = MemoryEnd(2)
write(0,*)'ext_mcel_read_field ',DataHandle, TRIM(DateStr), TRIM(VarName)
inttypesize = itypesize
realtypesize = rtypesize
IF ( FieldType .EQ. WRF_REAL ) THEN
typesize = rtypesize
mcel_type = MCEL_DATATYPE_REAL
ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
mcel_type = MCEL_DATATYPE_DOUBLE
ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
typesize = itypesize
mcel_type = MCEL_DATATYPE_INT32
ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
CALL wrf_error_fatal( 'io_int.F90: ext_mcel_write_field, WRF_LOGICAL not yet supported')
ENDIF
! case 1: the file is opened but not commited for update
write(0,*)' read_field: okay_to_read: ', DataHandle, okay_to_read(DataHandle)
write(0,*)' read_field: opened_for_update: ', DataHandle, opened_for_update(DataHandle)
if ( .not. okay_to_read( DataHandle ) ) then
IF ( opened_for_update( DataHandle) ) THEN
write(0,*)'ext_mcel_read_field tr calling ext_mcel_write_field ', TRIM(DateStr), TRIM(VarName)
CALL ext_mcel_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
DomainDesc , MemoryOrder , Stagger , DimNames , &
DomainStart , DomainEnd , &
MemoryStart , MemoryEnd , &
PatchStart , PatchEnd , &
ierr )
IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
ListOfFields(DataHandle) = TRIM(ListOfFields(DataHandle)) // ',' // TRIM(VarName)
ENDIF
write(0,*)'ext_mcel_read_field tr back from ext_mcel_write_field ', TRIM(DateStr), TRIM(VarName), ierr
ELSE
! these will have been set in the call to open_for_read_begin from sysdepinfo
IF ( mcel_npglobal .NE. -1 .AND. mcel_mystart .NE. -1 .AND. &
mcel_mnproc .NE. -1 .AND. mcel_myproc .NE. -1 ) THEN
write(0,*)'ext_mcel_read_field tr setglobalsize ', TRIM(VarName), mcel_npglobal
call setglobalsize(open_file_descriptors(2,DataHandle),mcel_npglobal,ierr)
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setglobalsize")
write(0,*)'ext_mcel_read_field tr setglobalstart ', TRIM(VarName), mcel_mystart
call setglobalstart(open_file_descriptors(2,DataHandle),mcel_mystart,ierr)
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setglobalstart")
#if 0
call setprocinfo(open_file_descriptors(1,DataHandle),mcel_mnproc,mcel_myproc,ierr)
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setprocinfo")
#endif
ENDIF
mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1
! sieve the fields coming in and grab the ones we need for geo registration
IF ( TRIM(VarName) .EQ. TRIM(LAT_R(DataHandle)) ) THEN
IF ( ALLOCATED(xlat) ) THEN
DEALLOCATE(xlat)
ENDIF
ALLOCATE(xlat(ips:ipe,jps:jpe))
IF ( FieldType .EQ. WRF_REAL ) THEN
CALL copy_field_to_cache_r2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
CALL copy_field_to_cache_d2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
ENDIF
ELSE IF ( TRIM(VarName) .EQ. TRIM(LON_R(DataHandle)) ) THEN
IF ( ALLOCATED(xlong) ) THEN
DEALLOCATE(xlong)
ENDIF
ALLOCATE(xlong(ips:ipe,jps:jpe))
IF ( FieldType .EQ. WRF_REAL ) THEN
CALL copy_field_to_cache_r2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
CALL copy_field_to_cache_d2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
ENDIF
ELSE IF ( TRIM(VarName) .EQ. TRIM(LANDMASK_I(DataHandle)) ) THEN
IF ( ALLOCATED(mask) ) THEN
DEALLOCATE(mask)
ENDIF
ALLOCATE(mask(ips:ipe,jps:jpe))
IF ( FieldType .EQ. WRF_INTEGER ) THEN
CALL copy_field_to_cache_int ( Field, mask, ips, ipe, jps, jpe, ims, ime, jms, jme )
ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
ALLOCATE(rmask(ips:ipe,jps:jpe))
CALL copy_field_to_cache_r2r ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
mask = NINT( rmask )
DEALLOCATE(rmask)
ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
ALLOCATE(dmask(ips:ipe,jps:jpe))
CALL copy_field_to_cache_d2d ( Field, dmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
mask = NINT( dmask )
DEALLOCATE(dmask)
ENDIF
ELSE
IF ( .NOT. mcel_grid_defined( DataHandle ) ) THEN
mcel_grid_defined( DataHandle ) = .true.
gSize(1) = ipe-ips+1
gSize(2) = jpe-jps+1
write(0,*)'ext_mcel_read_field tr setSize ', TRIM(VarName), gSize
CALL setSize ( open_file_descriptors(2,DataHandle), gSize, ierr )
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setSize")
ENDIF
write(0,*)'ext_mcel_read_field tr addSources ', TRIM(VarName), mcel_type
CALL addSources ( open_file_descriptors(1,DataHandle), MCEL_SERVER, &
& TRIM(VarName),1, mcel_type, ierr )
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addSources")
write(0,*)'ext_mcel_read_field tr addOutputs ', TRIM(VarName), mcel_type
CALL addOutputs ( open_file_descriptors(1,DataHandle), &
& TRIM(VarName),1, mcel_type, ierr )
! add this field to the list that we know something about
ListOfFields(DataHandle) = TRIM(ListOfFields(DataHandle)) // ',' // TRIM(VarName)
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addOutputs")
ENDIF
ENDIF
! case 2: opened for update and committed
! else if ( okay_to_write( DataHandle ) .and. opened_for_update( DataHandle) ) then
else if ( okay_to_read( DataHandle ) ) then
write(0,*)'ext_mcel_read_field ok ', Trim(VarName)
write(0,*)'ext_mcel_read_field LAT_R ', Trim(LAT_R(DataHandle))
write(0,*)'ext_mcel_read_field LON_R ', Trim(LON_R(DataHandle))
write(0,*)'ext_mcel_read_field LANDMASK_I ', Trim(LANDMASK_I(DataHandle))
IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
IF ( .NOT. mcel_finalized( DataHandle ) ) THEN
IF ( ALLOCATED( xlat ) .AND. ALLOCATED( xlong ) ) THEN
write(0,*)'ext_mcel_read_field ok setlocationsXY ', Trim(VarName)
!call wrf_get_myproc(myproc)
!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' xlong in read_field before setMask'
!do j=jps,jpe
!do i=ips,ipe
!write(90+myproc,*)xlong(i,j)
!enddo
!enddo
!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' xlat in read_field before setMask'
!do j=jps,jpe
!do i=ips,ipe
!write(90+myproc,*)xlat(i,j)
!enddo
!enddo
CALL setLocationsXY( open_file_descriptors(2,DataHandle), xlong, xlat, ierr )
IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_read_field: setLocationsXY" )
ELSE IF ( deltax .gt. 0. .and. deltay .gt. 0. .and. originx .gt. 0. .and. originy .gt. 0. ) THEN
dxm(1) = deltax
dxm(2) = deltay
call SetDX ( open_file_descriptors(2,DataHandle), dxm, ierr)
origin(1) = originx
origin(2) = originy
call SetOrigin ( open_file_descriptors(2,DataHandle), origin, ierr)
ELSE
CALL wrf_error_fatal( "ext_mcel_read_field:noLocationsXY or dx/dy")
ENDIF
IF ( ALLOCATED(mask) ) THEN
!write(0,*)'ext_mcel_read_field ok setMask ', Trim(VarName)
!call wrf_get_myproc(myproc)
!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' mask in read_field before setMask'
!do j=jps,jpe
!do i=ips,ipe
!write(90+myproc,*)mask(i,j)
!enddo
!enddo
CALL setMask ( open_file_descriptors(2,DataHandle) , mask, ierr )
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setMask")
ENDIF
write(0,*)'ext_mcel_read_field ok setoutputgrid ', Trim(VarName)
CALL setoutputgrid ( open_file_descriptors(1,DataHandle), open_file_descriptors(2,DataHandle), ierr )
IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setoutputgrid")
write(0,*)'ext_mcel_read_field ok finalizefilters ', Trim(VarName)
CALL finalizefilters ( open_file_descriptors(1,DataHandle), ierr )
IF ( ierr .GT. 0 .and. ierr .ne. 3 ) THEN
write(mess,*)'ext_mcel_open_for_read_field: finalizefilters ierr=',ierr
CALL wrf_error_fatal( TRIM(mess) )
ENDIF
mcel_finalized( DataHandle ) = .TRUE.
ENDIF
! a little string munging, assumes that we're getting an ISO compliant date string
! basically removing the delimeters
timestr = " "
timestr(1:4) = DateStr(1:4) ! YYYY
timestr(5:6) = DateStr(6:7) ! MM
timestr(7:8) = DateStr(9:10) ! DD
timestr(9:10) = DateStr(12:13) ! HH
timestr(11:12) = DateStr(15:16) ! MM
timestr(13:14) = DateStr(18:19) ! SS
CALL YYYYMMDDHHMMSS2SECS( timestr, data_time )
write(0,*)'TRIM( VarName ) ',TRIM( VarName )
write(0,*)'TRIM( ListOfFields(DataHandle) ) ',TRIM( ListOfFields(DataHandle) )
write(0,*)'INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) )', INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) )
IF ( INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) ) .EQ. 0 ) THEN
write(mess,*)'ext_mcel_open_for_read_field: ',TRIM( VarName ),' is not a field set up for DataHandle ', DataHandle
CALL wrf_error_fatal( TRIM(mess) )
ENDIF
IF ( FieldType .EQ. WRF_REAL ) THEN
ALLOCATE(temp(ips:ipe,jps:jpe))
write(0,*)'ext_mcel_read_field opened_for_update(DataHandle) ',opened_for_update(DataHandle)
IF ( opened_for_update(DataHandle) ) THEN
CALL copy_field_to_cache_r2r ( Field, temp, ips, ipe, jps, jpe, ims, ime, jms, jme )
!call wrf_get_myproc(myproc)
!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' temp in read_field before getData'
!do j=jps,jpe
!do i=ips,ipe
!write(90+myproc,*)temp(i,j)
!enddo
!enddo
call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),temp, &
data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle), &
MCEL_FETCHPOLICY_KEEPBLOCK,ierr)
!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' temp in read_field after getData'
!do j=jps,jpe
!do i=ips,ipe
!write(90+myproc,*)temp(i,j)
!enddo
!enddo
!write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
ELSE
! the difference is there is no KEEP in the FETCHPOLICY
write(0,*)'ext_mcel_read_field ok getData ', Trim(VarName)
call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),temp, &
data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle), &
MCEL_FETCHPOLICY_BLOCK,ierr)
write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
ENDIF
CALL copy_cache_to_field_r2r ( temp, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
DEALLOCATE(temp)
ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
ALLOCATE(dtemp(ips:ipe,jps:jpe))
write(0,*)'ext_mcel_read_field opened_for_update(DataHandle) ',opened_for_update(DataHandle)
IF ( opened_for_update(DataHandle) ) THEN
CALL copy_field_to_cache_d2d ( Field, dtemp, ips, ipe, jps, jpe, ims, ime, jms, jme )
write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),dtemp, &
data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle), &
MCEL_FETCHPOLICY_KEEPBLOCK,ierr)
ELSE
! the difference is there is no KEEP in the FETCHPOLICY
write(0,*)'ext_mcel_read_field ok getData ', Trim(VarName)
call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),dtemp, &
data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle), &
MCEL_FETCHPOLICY_BLOCK,ierr)
write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
ENDIF
CALL copy_cache_to_field_d2d ( dtemp, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
DEALLOCATE(dtemp)
ENDIF
ENDIF
endif
Status = 0
RETURN
END SUBROUTINE ext_mcel_read_field