subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, &
datestr_all,varname_all,domainend_all, &
start_block,end_block,start_byte,end_byte,file_offset, &
print_diag)
!$$$ subprogram documentation block
! . . . .
! subprogram: inventory_wrf_binary_file get contents of wrf binary file
! prgmmr: parrish org: np22 date: 2004-11-29
!
! abstract: generate list of contents and map of wrf binary file which can be
! used for reading and writing with mpi io routines.
! same basic routine as count_recs_wrf_binary_file, except
! now wrf unpacking routines are used to decode wrf header
! records, and send back lists of variable mnemonics, dates,
! grid dimensions, and byte addresses relative to start of
! file for each field (this is used by mpi io routines).
!
! program history log:
! 2004-11-29 parrish
!
!
! input argument list:
! in_unit - fortran unit number where input file is opened through.
! wrf_ges_filename - filename of input wrf binary restart file
! nrecs - number of sequential records found on input wrf binary restart file.
! (obtained by a previous call to count_recs_wrf_binary_file)
!
! output argument list: (all following dimensioned nrecs)
! datestr_all - date character string for each field, where applicable (or else blanks)
! varname_all - wrf mnemonic for each variable, where applicable (or blank)
! domainend_all - dimensions of each field, where applicable (up to 3 dimensions)
! start_block - direct access block number containing 1st byte of record
! (after 4 byte record mark)
! end_block - direct access block number containing last byte of record
! (before 4 byte record mark)
! start_byte - relative byte address in direct access block of 1st byte of record
! end_byte - relative byte address in direct access block of last byte of record
! file_offset - absolute address of byte before 1st byte of record (used by mpi io)
!
! attributes:
! language: f90
! machine: ibm RS/6000 SP
!
!$$$
use kinds, only: r_single,i_byte,i_long,i_llong
use module_internal_header_util
implicit none
integer,intent(in)::in_unit,nrecs
character(*),intent(in)::wrf_ges_filename
character(132),intent(out)::datestr_all(nrecs),varname_all(nrecs)
integer,intent(out)::domainend_all(3,nrecs)
integer,intent(out)::start_block(nrecs),end_block(nrecs)
integer,intent(out)::start_byte(nrecs),end_byte(nrecs)
integer(i_llong),intent(out)::file_offset(nrecs)
integer irecs
integer(i_llong) nextbyte,locbyte,thisblock
integer(i_byte) lenrec4(4)
integer(i_long) lenrec,lensave
equivalence (lenrec4(1),lenrec)
integer(i_byte) missing4(4)
integer(i_long) missing
equivalence (missing,missing4(1))
integer(i_llong),parameter:: lrecl=2**20
integer(i_byte) buf(lrecl)
integer i,loc_count,nreads
logical lastbuf, print_diag
integer(i_byte) hdrbuf4(2048)
integer(i_long) hdrbuf(512)
equivalence(hdrbuf(1),hdrbuf4(1))
integer,parameter:: int_field = 530
integer,parameter:: int_dom_ti_char = 220
integer hdrbufsize
integer inttypesize
integer datahandle
character(128) element,dumstr,strdata
integer loccode
character(132) blanks
integer typesize
integer fieldtype,comm,iocomm
integer domaindesc
character(132) memoryorder,stagger,dimnames(3)
integer domainstart(3),domainend(3)
integer memorystart(3),memoryend(3)
integer patchstart(3),patchend(3)
character(132) datestr,varname
real(r_single) dummy_field(1)
! integer dummy_field
! real dummy_field
integer itypesize
call wrf_sizeof_integer(itypesize)
inttypesize=itypesize
blanks=trim(' ')
open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl)
irecs=0
missing=-9999
nextbyte=0_i_llong
locbyte=lrecl
nreads=0
lastbuf=.false.
do
! get length of next record
do i=1,4
nextbyte=nextbyte+1_i_llong
locbyte=locbyte+1_i_llong
if(locbyte > lrecl .and. lastbuf) go to 900
if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
lenrec4(i)=buf(locbyte)
end do
if(lenrec <= 0 .and. lastbuf) go to 900
if(lenrec <= 0 .and. .not. lastbuf) go to 885
nextbyte=nextbyte+1_i_llong
locbyte=locbyte+1_i_llong
if(locbyte > lrecl .and. lastbuf) go to 900
if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
irecs=irecs+1
start_block(irecs)=thisblock
start_byte(irecs)=locbyte
file_offset(irecs)=nextbyte-1_i_llong
hdrbuf4(1)=buf(locbyte)
hdrbuf4(2:4)=missing4(2:4)
hdrbuf4(5:8)=missing4(1:4)
datestr_all(irecs)=blanks
varname_all(irecs)=blanks
domainend_all(1:3,irecs)=0
loc_count=1
do i=2,8
if(loc_count.ge.lenrec) exit
loc_count=loc_count+1
nextbyte=nextbyte+1_i_llong
locbyte=locbyte+1_i_llong
if(locbyte > lrecl .and. lastbuf) go to 900
if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
hdrbuf4(i)=buf(locbyte)
end do
if (print_diag)then
if(lenrec==2048) write(6,*)' irecs,hdrbuf(2),int_dom_ti_char,int_field=', &
irecs,hdrbuf(2),int_dom_ti_char,int_field
endif
if(lenrec==2048.and.(hdrbuf(2) == int_dom_ti_char .or. hdrbuf(2) == int_field)) then
! bring in next full record, so we can unpack datestr, varname, and domainend
do i=9,lenrec
loc_count=loc_count+1
nextbyte=nextbyte+1_i_llong
locbyte=locbyte+1_i_llong
if(locbyte > lrecl .and. lastbuf) go to 900
if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
hdrbuf4(i)=buf(locbyte)
end do
if(hdrbuf(2) == int_dom_ti_char) then
call int_get_ti_header_char(hdrbuf,hdrbufsize,inttypesize, &
datahandle,element,dumstr,strdata,loccode)
varname_all(irecs)=trim(element)
datestr_all(irecs)=trim(strdata)
if (print_diag)then
write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),trim(datestr_all(irecs))
endif
else
call int_get_write_field_header(hdrbuf,hdrbufsize,inttypesize,typesize, &
datahandle,datestr,varname,dummy_field,fieldtype,comm,iocomm, &
domaindesc,memoryorder,stagger,dimnames, &
domainstart,domainend,memorystart,memoryend,patchstart,patchend)
varname_all(irecs)=trim(varname)
datestr_all(irecs)=trim(datestr)
domainend_all(1:3,irecs)=domainend(1:3)
if (print_diag)then
write(6,*)' irecs,datestr,domend,varname = ', &
irecs,trim(datestr_all(irecs)),domainend_all(1:3,irecs),trim(varname_all(irecs))
endif
end if
end if
nextbyte=nextbyte-loc_count+lenrec
locbyte=locbyte-loc_count+lenrec
if(locbyte > lrecl .and. lastbuf) go to 900
if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
end_block(irecs)=thisblock
end_byte(irecs)=locbyte
lensave=lenrec
do i=1,4
nextbyte=nextbyte+1_i_llong
locbyte=locbyte+1_i_llong
if(locbyte > lrecl .and. lastbuf) go to 900
if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
lenrec4(i)=buf(locbyte)
end do
if(lenrec /= lensave) go to 890
end do
880 continue
write(6,*)' reached impossible place in inventory_wrf_binary_file'
close(in_unit)
return
885 continue
write(6,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file'
write(6,*)' lenrec =',lenrec
close(in_unit)
return
890 continue
write(6,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal'
write(6,*)' begining reclen =',lensave
write(6,*)' ending reclen =',lenrec
write(6,*)' irecs =',irecs
write(6,*)' nrecs =',nrecs
close(in_unit)
return
900 continue
write(6,*)' normal end of file reached in inventory_wrf_binary_file'
write(6,*)' nblocks=',thisblock
write(6,*)' irecs,nrecs=',irecs,nrecs
write(6,*)' nreads=',nreads
close(in_unit)
end subroutine inventory_wrf_binary_file
SUBROUTINE wrf_sizeof_integer( retval )
IMPLICIT NONE
INTEGER retval
! 4 is defined by CPP
retval = 4
RETURN
END SUBROUTINE wrf_sizeof_integer
SUBROUTINE wrf_sizeof_real( retval )
IMPLICIT NONE
INTEGER retval
! 4 is defined by CPP
retval = 4
RETURN
END SUBROUTINE wrf_sizeof_real