!-------------------------------------------------------------------------------
module sigio_r_module
!$$$ Module Documentation Block
!
! Module: sigio_r_module API for global spectral sigma file random I/O
! Prgmmr: Iredell Org: W/NX23 Date: 1999-01-18
!
! Abstract: This module provides an Application Program Interface extension
! for performing I/O on the sigma restart file of the global spectral model.
! Functions include opening, reading, writing, and closing as well as
! allocating and deallocating data buffers used in the transfers.
! The I/O performed here is random.
! The transfers are limited to header records, data records,
! surface data records, or specific levels of upper air data records.
! See the documentation for sigio_module for sequential I/O.
!
! Program History Log:
! 1999-01-18 Mark Iredell
!
! Modules Used:
! sigio_module API for global spectral sigma file I/O
!
! Public Variables:
!
! Public Defined Types:
! sigio_dats Sigma file surface data fields
! hs Real(sigio_realkind)(:) pointer to spectral
! coefficients of surface height in m
! ps Real(sigio_realkind)(:) pointer to spectral
! coefficients of log of surface pressure over 1 kPa
!
! sigio_datm Sigma file multilevel data fields
! k1 Integer(sigio_intkind) first level number
! k2 Integer(sigio_intkind) last level number
! t Real(sigio_realkind)(:,:) pointer to spectral
! coefficients of virtual temperature by level in K
! d Real(sigio_realkind)(:,:) pointer to spectral
! coefficients of divergence by level in 1/second
! z Real(sigio_realkind)(:,:) pointer to spectral
! coefficients of vorticity by level in 1/second
! q Real(sigio_realkind)(:,:,:) pointer to spectral
! coefficients of tracers by tracer number and level
! in specific densities
!
! sigio_dati Sigma file single data field
! i Integer(sigio_intkind) record index
! f Real(sigio_realkind)(:) pointer to field
!
! sigio_dbts Sigma file longreal surface data fields
! hs Real(sigio_dblekind)(:) pointer to spectral
! coefficients of surface height in m
! ps Real(sigio_dblekind)(:) pointer to spectral
! coefficients of log of surface pressure over 1 kPa
!
! sigio_dbtm Sigma file longreal multilevel data fields
! k1 Integer(sigio_intkind) first level number
! k2 Integer(sigio_intkind) last level number
! t Real(sigio_dblekind)(:,:) pointer to spectral
! coefficients of virtual temperature by level in K
! d Real(sigio_dblekind)(:,:) pointer to spectral
! coefficients of divergence by level in 1/second
! z Real(sigio_dblekind)(:,:) pointer to spectral
! coefficients of vorticity by level in 1/second
! q Real(sigio_dblekind)(:,:,:) pointer to spectral
! coefficients of tracers by tracer number and level
! in specific densities
!
! sigio_dbti Sigma file longreal single data field
! i Integer(sigio_intkind) record index
! f Real(sigio_dblekind)(:) pointer to field
!
! Public Subprograms:
! sigio_rropen Open sigma file for random reading
! lu Integer(sigio_intkind) input logical unit
! cfname Character(*) input filename
! iret Integer(sigio_intkind) output return code
!
! sigio_rwopen Open sigma file for random writing
! lu Integer(sigio_intkind) input logical unit
! cfname Character(*) input filename
! iret Integer(sigio_intkind) output return code
!
! sigio_rxopen Open sigma file for random reading and writing
! lu Integer(sigio_intkind) input logical unit
! cfname Character(*) input filename
! iret Integer(sigio_intkind) output return code
!
! sigio_rclose Close sigma file for random I/O
! lu Integer(sigio_intkind) input logical unit
! iret Integer(sigio_intkind) output return code
!
! sigio_rrhead Read header information with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) output header information
! iret Integer(sigio_intkind) output return code
!
! sigio_rwhead Write header information with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! iret Integer(sigio_intkind) output return code
!
! sigio_aldats Allocate surface data fields
! head Type(sigio_head) input header information
! dats Type(sigio_dats) output surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_axdats Deallocate surface data fields
! dats Type(sigio_dats) output surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_aldatm Allocate multilevel data fields
! head Type(sigio_head) input header information
! k1 Integer(sigio_intkind) input first level number
! k2 Integer(sigio_intkind) input last level number
! datm Type(sigio_datm) output multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_axdatm Deallocate multilevel data fields
! datm Type(sigio_datm) output multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_aldati Allocate single data fields
! head Type(sigio_head) input header information
! i Integer(sigio_intkind) input record index
! dati Type(sigio_dati) output single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_axdati Deallocate single data fields
! dati Type(sigio_dati) output single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdata Read data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! data Type(sigio_data) output data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdata Write data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! data Type(sigio_data) input data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrohdc Open, read header & data and close with random I/O
! lu Integer(sigio_intkind) input logical unit
! cfname Character(*) input filename
! head Type(sigio_head) output header information
! data Type(sigio_data) or type(sigio_dbta) output data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwohdc Open, write header & data and close with random I/O
! lu Integer(sigio_intkind) input logical unit
! cfname Character(*) input filename
! head Type(sigio_head) input header information
! data Type(sigio_data) or type(sigio_dbta) input data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdats Read surface data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dats Type(sigio_dats) output surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdats Write surface data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dats Type(sigio_dats) input surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdatm Read multilevel data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! datm Type(sigio_datm) output multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdatm Write multilevel data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! datm Type(sigio_datm) input multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdati Read single data field with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dati Type(sigio_dati) output single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdati Write single data field with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dati Type(sigio_dati) input single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_aldbts Allocate longreal surface data fields
! head Type(sigio_head) input header information
! dbts Type(sigio_dbts) output longreal surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_axdbts Deallocate longreal surface data fields
! dbts Type(sigio_dbts) output longreal surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_aldbtm Allocate longreal multilevel data fields
! head Type(sigio_head) input header information
! k Integer(sigio_intkind) input level number
! dbtm Type(sigio_dbtm) output longreal multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_axdbtm Deallocate longreal multilevel data fields
! dbtm Type(sigio_dbtm) output longreal multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_aldbti Allocate longreal single data fields
! head Type(sigio_head) input header information
! i Integer(sigio_intkind) input record index
! dbti Type(sigio_dbti) output longreal single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_axdbti Deallocate longreal single data fields
! dbti Type(sigio_dbti) output longreal single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdbta Read longreal data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbta Type(sigio_dbta) output longreal data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdbta Write longreal data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbta Type(sigio_dbta) input longreal data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdbts Read longreal surface data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbts Type(sigio_dbts) output longreal surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdbts Write longreal surface data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbts Type(sigio_dbts) input longreal surface data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdbtm Read longreal multilevel data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbtm Type(sigio_dbtm) output longreal multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdbtm Write longreal multilevel data fields with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbtm Type(sigio_dbtm) input longreal multilevel data fields
! iret Integer(sigio_intkind) output return code
!
! sigio_rrdbti Read longreal single data field with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbti Type(sigio_dbti) output longreal single data field
! iret Integer(sigio_intkind) output return code
!
! sigio_rwdbti Write longreal single data field with random I/O
! lu Integer(sigio_intkind) input logical unit
! head Type(sigio_head) input header information
! dbti Type(sigio_dbti) input longreal single data field
! iret Integer(sigio_intkind) output return code
!
! Subprograms called:
! baopenr Byte-addressable open for reading
! baopenw Byte-addressable open for writing
! baclose Byte-addressable close
! bafrindexl Byte-addressable Fortran record index
! bafrreadl Byte-addressable Fortran record read
! bafrwritel Byte-addressable Fortran record write
!
! Remarks:
! (1) The sigma file format follows:
! ON85 label (32 bytes)
! Header information record containing
! real forecast hour, initial date, sigma interfaces, sigma levels,
! padding to allow for 100 levels, and finally 44 identifier words
! containing JCAP, LEVS, NTRAC, etc. (250 4-byte words)
! Orography (NC 4-byte words, where NC=(JCAP+1)*(JCAP+2))
! Log surface pressure (NC 4-byte words)
! Temperature (LEVS records of NC 4-byte words)
! Divergence & Vorticity interleaved (2*LEVS records of NC 4-byte words)
! Tracers (LEVS*NTRAC records of NC 4-byte words)
!
! (2) Possible return codes:
! 0 Successful call
! -1 Open or close I/O error
! -2 Header record I/O error (possible EOF)
! -3 Allocation or deallocation error
! -4 Data record I/O error
! -5 Insufficient data dimensions allocated
!
! Examples:
! (1) Write out orography and surface pressure only from processor 0:
!
! subroutine write_surface_fields(me,head,len,orog,lnps)
! use sigio_r_module
! integer,intent(in):: me
! type(sigio_head),intent(in):: head
! integer,intent(in):: len
! real(sigio_dblekind),intent(in),target:: orog(len),lnps(len)
! type(sigio_dbts) dbts
! integer iret
! if(me.eq.0) then
! dbts%hs=>orog
! dbts%ps=>lnps
! call sigio_rwdbts(51,head,dbts,iret)
! endif
! end subroutine
!
! Attributes:
! Language: Fortran 90
!
!$$$
use sigio_module
implicit none
private
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Public Variables
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Public Types
type,public:: sigio_dats
real(sigio_realkind),pointer:: hs(:),ps(:)
end type
type,public:: sigio_datm
integer(sigio_intkind):: k1,k2
real(sigio_realkind),pointer:: t(:,:),d(:,:),z(:,:)
real(sigio_realkind),pointer:: q(:,:,:)
end type
type,public:: sigio_dati
integer(sigio_intkind):: i
real(sigio_realkind),pointer:: f(:)
end type
type,public:: sigio_dbts
real(sigio_dblekind),pointer:: hs(:),ps(:)
end type
type,public:: sigio_dbtm
integer(sigio_intkind):: k1,k2
real(sigio_dblekind),pointer:: t(:,:),d(:,:),z(:,:)
real(sigio_dblekind),pointer:: q(:,:,:)
end type
type,public:: sigio_dbti
integer(sigio_intkind):: i
real(sigio_dblekind),pointer:: f(:)
end type
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Private Variables
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Private Types
type sigio_head2
sequence
real(sigio_realkind):: fhour
integer(sigio_intkind):: idate(4)
real(sigio_realkind):: sisl(2*100+1)
real(sigio_realkind):: ext(44)
end type
type sigio_head1a
sequence
character(8):: clab8
integer(sigio_intkind):: ivs,nhead,ndata,reserved(3)
end type
type sigio_head3a
sequence
real(sigio_realkind) fhour
integer(sigio_intkind):: idate(4)
integer(sigio_intkind):: jcap,levs,&
itrun,iorder,irealf,igen,latf,lonf,&
latb,lonb,latr,lonr,ntrac,nvcoord,&
icen2,iens(2),idpp,idsl,idvc,idvm,&
idvt,idrun,idusr
real(sigio_realkind) pdryini
integer(sigio_intkind):: ncldt,ixgr
integer(sigio_intkind):: reserved(18)
end type
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Public Subprograms
public sigio_rropen,sigio_rwopen,sigio_rxopen,sigio_rclose
public sigio_rrhead,sigio_rwhead
public sigio_aldats,sigio_axdats
public sigio_aldatm,sigio_axdatm
public sigio_aldati,sigio_axdati
public sigio_rrdata,sigio_rwdata
public sigio_rrohdc,sigio_rwohdc
public sigio_rrdats,sigio_rwdats
public sigio_rrdatm,sigio_rwdatm
public sigio_rrdati,sigio_rwdati
public sigio_aldbts,sigio_axdbts
public sigio_aldbtm,sigio_axdbtm
public sigio_aldbti,sigio_axdbti
public sigio_rrdbta,sigio_rwdbta
public sigio_rrdbts,sigio_rwdbts
public sigio_rrdbtm,sigio_rwdbtm
public sigio_rrdbti,sigio_rwdbti
interface sigio_rrohdc
module procedure sigio_rrohdca,sigio_rrohdcb
end interface
interface sigio_rwohdc
module procedure sigio_rwohdca,sigio_rwohdcb
end interface
contains
!-------------------------------------------------------------------------------
subroutine sigio_rropen(lu,cfname,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call baopenr(lu,cfname,iret)
if(iret.ne.0) iret=-1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwopen(lu,cfname,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call baopenw(lu,cfname,iret)
if(iret.ne.0) iret=-1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rxopen(lu,cfname,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call baopen(lu,cfname,iret)
if(iret.ne.0) iret=-1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rclose(lu,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call baclose(lu,iret)
if(iret.ne.0) iret=-1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrhead(lu,head,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(inout):: head
integer(sigio_intkind),intent(out):: iret
type(sigio_head2):: head2
type(sigio_head1a):: head1a
type(sigio_head3a):: head3a
integer(8):: iskip,iread,nread
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
iret=-2
iskip=0
iread=sigio_lhead1
call bafrreadl(lu,iskip,iread,nread,head1a)
if(nread.lt.iread) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head1a%clab8.eq.'GFS SIG ') then ! modern sigma file
head%ivs=head1a%ivs
call bafrindexl(lu,iskip+nread,nread,iskip)
iread=200
call bafrreadl(lu,iskip,iread,nread,head3a)
if(nread.lt.iread) return
head%fhour=head3a%fhour
head%idate=head3a%idate
head%jcap=head3a%jcap
head%levs=head3a%levs
head%itrun=head3a%itrun
head%iorder=head3a%iorder
head%irealf=head3a%irealf
head%igen=head3a%igen
head%latf=head3a%latf
head%lonf=head3a%lonf
head%latb=head3a%latb
head%lonb=head3a%lonb
head%latr=head3a%latr
head%lonr=head3a%lonr
head%ntrac=head3a%ntrac
head%nvcoord=head3a%nvcoord
head%icen2=head3a%icen2
head%iens=head3a%iens
head%idpp=head3a%idpp
head%idsl=head3a%idsl
head%idvc=head3a%idvc
head%idvm=head3a%idvm
head%idvt=head3a%idvt
head%idrun=head3a%idrun
head%idusr=head3a%idusr
head%pdryini=head3a%pdryini
head%ncldt=head3a%ncldt
head%ixgr=head3a%ixgr
call sigio_alhead(head,iret)
iskip=iskip+nread
iread=4*size(head%vcoord)
call bafrreadl(lu,iskip,iread,nread,head%vcoord)
if(nread.lt.iread) return
iskip=iskip+nread
iread=size(head%cfvars)
call bafrreadl(lu,iskip,iread,nread,head%cfvars)
if(nread.lt.iread) return
!
if (mod(head%idvm/10,10) == 3) then
iskip=iskip+nread
iread=4*size(head%cpi)
call bafrreadl(lu,iskip,iread,nread,head%cpi)
if(nread.lt.iread) return
iskip=iskip+nread
iread=4*size(head%ri)
call bafrreadl(lu,iskip,iread,nread,head%ri)
if(nread.lt.iread) return
endif
head%clabsig=' '
head%si=sigio_realfill
head%sl=sigio_realfill
head%ak=sigio_realfill
head%bk=sigio_realfill
head%pdryini=sigio_realfill
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
else
iskip=0
iread=sigio_lhead1
call bafrreadl(lu,iskip,iread,nread,head%clabsig)
if(nread.lt.iread) return
iskip=iskip+nread
iread=1000
call bafrreadl(lu,iskip,iread,nread,head2)
if(nread.lt.iread) return
iret=0
head%fhour=head2%fhour
head%idate=head2%idate
head%jcap=head2%ext(1)
head%levs=head2%ext(2)
head%itrun=head2%ext(3)
head%iorder=head2%ext(4)
head%irealf=head2%ext(5)
head%igen=head2%ext(6)
head%lonf=head2%ext(7)
head%latf=head2%ext(8)
head%lonb=head2%ext(9)
head%latb=head2%ext(10)
head%lonr=head2%ext(11)
head%latr=head2%ext(12)
head%ntrac=max(head2%ext(13),1.)
head%icen2=head2%ext(14)
head%iens=head2%ext(15:16)
head%idpp=head2%ext(17)
head%idsl=head2%ext(18)
head%idvc=head2%ext(19)
head%idvm=head2%ext(20)
head%idvt=head2%ext(21)
head%idrun=head2%ext(22)
head%idusr=head2%ext(23)
head%pdryini=head2%ext(24)
head%ncldt=head2%ext(25)
head%si=sigio_realfill
head%sl=sigio_realfill
head%ak=sigio_realfill
head%bk=sigio_realfill
if(head%idvc.eq.2) then
head%ak(1:head%levs+1)=head2%sisl(1:head%levs+1)
head%bk(1:head%levs+1)=head2%sisl(head%levs+2:2*head%levs+2)
else
head%si(1:head%levs+1)=head2%sisl(1:head%levs+1)
head%sl(1:head%levs)=head2%sisl(head%levs+2:2*head%levs+1)
endif
head%ivs=198410
if(head%idvc.eq.2) then
head%nvcoord=2
call sigio_alhead(head,iret)
head%vcoord(1:head%levs+1,1)=head%ak(1:head%levs+1)
head%vcoord(1:head%levs+1,2)=head%bk(1:head%levs+1)
elseif(head%idvc.eq.0.or.head%idvc.eq.1) then
head%nvcoord=1
call sigio_alhead(head,iret)
head%vcoord(1:head%levs+1,1)=head%si(1:head%levs+1)
endif
endif
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_adhead(head)
iret=0
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwhead(lu,head,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(inout):: head
integer(sigio_intkind),intent(out):: iret
type(sigio_head2):: head2
type(sigio_head1a):: head1a
integer,allocatable:: head2a(:)
type(sigio_head3a):: head3a
integer(8):: iskip,iwrite,nwrite
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
iret=-2
call sigio_adhead(head)
if(head%ivs.ge.200509) then
head1a%clab8='GFS SIG '
head1a%ivs=head%ivs
head1a%nhead=head%nhead
head1a%ndata=head%ndata
head1a%reserved=0
iskip=0
iwrite=head%lhead(1)
call bafrwritel(lu,iskip,iwrite,nwrite,head1a)
if(nwrite.lt.iwrite) return
allocate(head2a(head%nhead+head%ndata))
head2a(:head%nhead)=head%lhead
head2a(head%nhead+1:)=head%ldata
iskip=iskip+nwrite
iwrite=head%lhead(2)
call bafrwritel(lu,iskip,iwrite,nwrite,head2a)
deallocate(head2a)
if(nwrite.lt.iwrite) return
head3a%fhour=head%fhour
head3a%idate=head%idate
head3a%jcap=head%jcap
head3a%levs=head%levs
head3a%itrun=head%itrun
head3a%iorder=head%iorder
head3a%irealf=head%irealf
head3a%igen=head%igen
head3a%latf=head%latf
head3a%lonf=head%lonf
head3a%latb=head%latb
head3a%lonb=head%lonb
head3a%latr=head%latr
head3a%lonr=head%lonr
head3a%ntrac=head%ntrac
head3a%nvcoord=head%nvcoord
head3a%icen2=head%icen2
head3a%iens=head%iens
head3a%idpp=head%idpp
head3a%idsl=head%idsl
head3a%idvc=head%idvc
head3a%idvm=head%idvm
head3a%idvt=head%idvt
head3a%idrun=head%idrun
head3a%idusr=head%idusr
head3a%pdryini=head%pdryini
head3a%ncldt=head%ncldt
head3a%ixgr=head%ixgr
head3a%reserved=0
iskip=iskip+nwrite
iwrite=head%lhead(3)
call bafrwritel(lu,iskip,iwrite,nwrite,head3a)
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
iwrite=head%lhead(4)
call bafrwritel(lu,iskip,iwrite,nwrite,head%vcoord)
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
iwrite=head%lhead(5)
call bafrwritel(lu,iskip,iwrite,nwrite,head%cfvars)
if(nwrite.lt.iwrite) return
!
if (mod(head%idvm/10,10) == 3) then
iskip=iskip+nwrite
iwrite=head%lhead(7)
call bafrwritel(lu,iskip,iwrite,nwrite,head%cpi)
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
iwrite=head%lhead(7)
call bafrwritel(lu,iskip,iwrite,nwrite,head%ri)
if(nwrite.lt.iwrite) return
endif
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
else
iskip=0
iwrite=sigio_lhead1
call bafrwritel(lu,iskip,iwrite,nwrite,head%clabsig)
if(nwrite.lt.iwrite) return
head2%fhour=head%fhour
head2%idate=head%idate
head2%sisl=0
if(head%idvc.eq.2) then
if(head%nvcoord.eq.2.and.head%vcoord(1,2).eq.1.) then
head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1)
head2%sisl(head%levs+2:2*head%levs+2)=head%vcoord(1:head%levs+1,2)
else
head2%sisl(1:head%levs+1)=head%ak(1:head%levs+1)
head2%sisl(head%levs+2:2*head%levs+2)=head%bk(1:head%levs+1)
endif
elseif(head%idvc.eq.0.or.head%idvc.eq.1) then
if(head%nvcoord.eq.1.and.head%vcoord(1,1).eq.1.) then
head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1)
call sigio_modpr(1,1,head%levs,head%nvcoord,head%idvc,head%idsl,&
head%vcoord,iret,ps=(/1./),&
pm=head2%sisl(head%levs+2:2*head%levs+1))
else
head2%sisl(1:head%levs+1)=head%si(1:head%levs+1)
head2%sisl(head%levs+2:2*head%levs+1)=head%sl(1:head%levs)
endif
endif
head2%ext(1)=head%jcap
head2%ext(2)=head%levs
head2%ext(3)=head%itrun
head2%ext(4)=head%iorder
head2%ext(5)=head%irealf
head2%ext(6)=head%igen
head2%ext(7)=head%lonf
head2%ext(8)=head%latf
head2%ext(9)=head%lonb
head2%ext(10)=head%latb
head2%ext(11)=head%lonr
head2%ext(12)=head%latr
head2%ext(13)=head%ntrac
head2%ext(14)=head%icen2
head2%ext(15:16)=head%iens
head2%ext(17)=head%idpp
head2%ext(18)=head%idsl
head2%ext(19)=head%idvc
head2%ext(20)=head%idvm
head2%ext(21)=head%idvt
head2%ext(22)=head%idrun
head2%ext(23)=head%idusr
head2%ext(24)=head%pdryini
head2%ext(25)=head%ncldt
head2%ext(26:44)=0
iskip=iskip+nwrite
iwrite=1000
call bafrwritel(lu,iskip,iwrite,nwrite,head2)
if(nwrite.lt.iwrite) return
endif
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
iret=0
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_aldats(head,dats,iret)
implicit none
type(sigio_head),intent(in):: head
type(sigio_dats),intent(inout):: dats
integer(sigio_intkind),intent(out):: iret
integer nc,dim1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! call sigio_axdats(dats,iret)
if(associated(dats%hs)) call sigio_axdats(dats,iret)
nc=(head%jcap+1)*(head%jcap+2)
dim1=nc
allocate(dats%hs(dim1),dats%ps(dim1),stat=iret)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_axdats(dats,iret)
implicit none
type(sigio_dats),intent(inout):: dats
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
deallocate(dats%hs,dats%ps,stat=iret)
nullify(dats%hs,dats%ps)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_aldatm(head,k1,k2,datm,iret)
implicit none
type(sigio_head),intent(in):: head
integer(sigio_intkind),intent(in):: k1,k2
type(sigio_datm),intent(inout):: datm
integer(sigio_intkind),intent(out):: iret
integer nc,dim1,dim3q
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! call sigio_axdatm(datm,iret)
if(associated(datm%t)) call sigio_axdatm(datm,iret)
iret=-3
if(k1.lt.1.or.k2.gt.head%levs) return
nc=(head%jcap+1)*(head%jcap+2)
dim1=nc
dim3q=head%ntrac
datm%k1=k1
datm%k2=k2
allocate(datm%t(dim1,k1:k2),datm%d(dim1,k1:k2),datm%z(dim1,k1:k2),&
datm%q(dim1,k1:k2,dim3q),stat=iret)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_axdatm(datm,iret)
implicit none
type(sigio_datm),intent(inout):: datm
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
datm%k1=0
datm%k2=0
deallocate(datm%t,datm%d,datm%z,datm%q,stat=iret)
nullify(datm%t,datm%d,datm%z,datm%q)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_aldati(head,i,dati,iret)
implicit none
type(sigio_head),intent(in):: head
integer(sigio_intkind),intent(in):: i
type(sigio_dati),intent(inout):: dati
integer(sigio_intkind),intent(out):: iret
integer dim1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! call sigio_axdati(dati,iret)
if(associated(dati%f)) call sigio_axdati(dati,iret)
iret=-3
if(i.lt.1.or.i.gt.head%ndata) return
dim1=head%ldata(i)/(4*head%irealf)
dati%i=i
allocate(dati%f(dim1),stat=iret)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_axdati(dati,iret)
implicit none
type(sigio_dati),intent(inout):: dati
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
dati%i=0
deallocate(dati%f,stat=iret)
nullify(dati%f)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdata(lu,head,data,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_data),intent(inout):: data
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,mdim1,mdim2,mdim3q
integer(8):: iskip,iread,nread
type(sigio_dbta):: dbta
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(data%hs,1),size(data%ps,1),&
size(data%t,1),size(data%d,1),size(data%z,1),&
size(data%q,1))
mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),&
size(data%q,2))
mdim3q=size(data%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc.or.&
mdim2.lt.head%levs.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%hs)
if(nread.lt.iread) return
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%ps)
if(nread.lt.iread) return
do k=1,head%levs
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%t(1,k))
if(nread.lt.iread) return
enddo
do k=1,head%levs
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%d(1,k))
if(nread.lt.iread) return
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%z(1,k))
if(nread.lt.iread) return
enddo
do n=1,head%ntrac
do k=1,head%levs
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%q(1,k,n))
if(nread.lt.iread) return
enddo
enddo
do n=1,head%nxgr
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%xgr(1,1,n))
if(nread.lt.iread) return
enddo
if(head%nxss.gt.0) then
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,data%xss)
if(nread.lt.iread) return
endif
else
call sigio_aldbta(head,dbta,iret)
if(iret.ne.0) return
call sigio_rrdbta(lu,head,dbta,iret)
if(iret.ne.0) return
data%hs(:nc)=dbta%hs(:nc)
data%ps(:nc)=dbta%ps(:nc)
data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs)
data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs)
data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs)
data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac)
data%xgr(:head%lonb,:head%latb,:head%nxgr)=&
dbta%xgr(:head%lonb,:head%latb,:head%nxgr)
data%xss(:head%nxss)=dbta%xss(:head%nxss)
call sigio_axdbta(dbta,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdata(lu,head,data,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_data),intent(in):: data
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,mdim1,mdim2,mdim3q
integer(8):: iskip,iwrite,nwrite
type(sigio_dbta):: dbta
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(data%hs,1),size(data%ps,1),&
size(data%t,1),size(data%d,1),size(data%z,1),&
size(data%q,1))
mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),&
size(data%q,2))
mdim3q=size(data%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc.or.&
mdim2.lt.head%levs.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%hs)
if(nwrite.lt.iwrite) return
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%ps)
if(nwrite.lt.iwrite) return
do k=1,head%levs
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%t(1,k))
if(nwrite.lt.iwrite) return
enddo
do k=1,head%levs
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%d(1,k))
if(nwrite.lt.iwrite) return
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%z(1,k))
if(nwrite.lt.iwrite) return
enddo
do n=1,head%ntrac
do k=1,head%levs
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%q(1,k,n))
if(nwrite.lt.iwrite) return
enddo
enddo
do n=1,head%nxgr
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%xgr(1,1,n))
if(nwrite.lt.iwrite) return
enddo
if(head%nxss.gt.0) then
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,data%xss)
if(nwrite.lt.iwrite) return
endif
else
call sigio_aldbta(head,dbta,iret)
if(iret.ne.0) return
dbta%hs(:nc)=data%hs(:nc)
dbta%ps(:nc)=data%ps(:nc)
dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs)
dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs)
dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs)
dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac)
dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=&
data%xgr(:head%lonb,:head%latb,:head%nxgr)
dbta%xss(:head%nxss)=data%xss(:head%nxss)
call sigio_rwdbta(lu,head,dbta,iret)
if(iret.ne.0) return
call sigio_axdbta(dbta,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrohdca(lu,cfname,head,data,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
type(sigio_head),intent(inout):: head
type(sigio_data),intent(inout):: data
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rropen(lu,cfname,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rrhead(lu,head,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_aldata(head,data,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rrdata(lu,head,data,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rclose(lu,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwohdca(lu,cfname,head,data,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
type(sigio_head),intent(inout):: head
type(sigio_data),intent(in):: data
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rwopen(lu,cfname,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rwhead(lu,head,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rwdata(lu,head,data,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rclose(lu,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdats(lu,head,dats,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dats),intent(inout):: dats
integer(sigio_intkind),intent(out):: iret
integer:: i
integer:: nc,mdim1
integer(8):: iskip,iread,nread
type(sigio_dbts):: dbts
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(dats%hs,1),size(dats%ps,1))
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dats%hs)
if(nread.lt.iread) return
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dats%ps)
if(nread.lt.iread) return
else
call sigio_aldbts(head,dbts,iret)
if(iret.ne.0) return
call sigio_rrdbts(lu,head,dbts,iret)
if(iret.ne.0) return
dats%hs(:nc)=dbts%hs(:nc)
dats%ps(:nc)=dbts%ps(:nc)
call sigio_axdbts(dbts,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdats(lu,head,dats,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dats),intent(in):: dats
integer(sigio_intkind),intent(out):: iret
integer:: i
integer:: nc,mdim1
integer(8):: iskip,iwrite,nwrite
type(sigio_dbts):: dbts
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(dats%hs,1),size(dats%ps,1))
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dats%hs)
if(nwrite.lt.iwrite) return
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dats%ps)
if(nwrite.lt.iwrite) return
else
call sigio_aldbts(head,dbts,iret)
if(iret.ne.0) return
dbts%hs(:nc)=dats%hs(:nc)
dbts%ps(:nc)=dats%ps(:nc)
call sigio_rwdbts(lu,head,dbts,iret)
if(iret.ne.0) return
call sigio_axdbts(dbts,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdatm(lu,head,datm,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_datm),intent(inout):: datm
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q
integer(8):: iskip,iread,nread
type(sigio_dbtm):: dbtm
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
k1=datm%k1
k2=datm%k2
mdim1=min(size(datm%t,1),size(datm%d,1),size(datm%z,1),&
size(datm%q,1))
ldim2=max(lbound(datm%t,2),lbound(datm%d,2),lbound(datm%z,2),&
lbound(datm%q,2))
udim2=min(ubound(datm%t,2),ubound(datm%d,2),ubound(datm%z,2),&
ubound(datm%q,2))
mdim3q=size(datm%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(k1.lt.1.or.k2.gt.head%levs.or.&
mdim1.lt.nc.or.&
ldim2.gt.k1.or.udim2.lt.k2.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,datm%t(1,k))
if(nread.lt.iread) return
iskip=iskip+nread
endif
enddo
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,datm%d(1,k))
if(nread.lt.iread) return
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,datm%z(1,k))
if(nread.lt.iread) return
iskip=iskip+nread
endif
enddo
do n=1,head%ntrac
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,datm%q(1,k,n))
if(nread.lt.iread) return
iskip=iskip+nread
endif
enddo
enddo
else
call sigio_aldbtm(head,k1,k2,dbtm,iret)
if(iret.ne.0) return
call sigio_rrdbtm(lu,head,dbtm,iret)
if(iret.ne.0) return
datm%t(:nc,k1:k2)=dbtm%t(:nc,k1:k2)
datm%d(:nc,k1:k2)=dbtm%d(:nc,k1:k2)
datm%z(:nc,k1:k2)=dbtm%z(:nc,k1:k2)
datm%q(:nc,k1:k2,:head%ntrac)=dbtm%q(:nc,k1:k2,:head%ntrac)
call sigio_axdbtm(dbtm,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdatm(lu,head,datm,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_datm),intent(in):: datm
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q
integer(8):: iskip,iwrite,nwrite
type(sigio_dbtm):: dbtm
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
k1=datm%k1
k2=datm%k2
mdim1=min(size(datm%t,1),size(datm%d,1),size(datm%z,1),&
size(datm%q,1))
ldim2=max(lbound(datm%t,2),lbound(datm%d,2),lbound(datm%z,2),&
lbound(datm%q,2))
udim2=min(ubound(datm%t,2),ubound(datm%d,2),ubound(datm%z,2),&
ubound(datm%q,2))
mdim3q=size(datm%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(k1.lt.1.or.k2.gt.head%levs.or.&
mdim1.lt.nc.or.&
ldim2.gt.k1.or.udim2.lt.k2.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,datm%t(1,k))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
endif
enddo
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,datm%d(1,k))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,datm%z(1,k))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
endif
enddo
do n=1,head%ntrac
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,datm%q(1,k,n))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
endif
enddo
enddo
else
call sigio_aldbtm(head,k1,k2,dbtm,iret)
if(iret.ne.0) return
dbtm%t(:nc,k1:k2)=datm%t(:nc,k1:k2)
dbtm%d(:nc,k1:k2)=datm%d(:nc,k1:k2)
dbtm%z(:nc,k1:k2)=datm%z(:nc,k1:k2)
dbtm%q(:nc,k1:k2,:head%ntrac)=datm%q(:nc,k1:k2,:head%ntrac)
call sigio_rwdbtm(lu,head,dbtm,iret)
if(iret.ne.0) return
call sigio_axdbtm(dbtm,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdati(lu,head,dati,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dati),intent(inout):: dati
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: mdim1
integer:: mlen
integer(8):: iskip,iread,nread
type(sigio_dbti):: dbti
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
i=dati%i
mdim1=size(dati%f,1)
iret=-5
if(i.lt.1.or.i.gt.head%ndata) return
mlen=head%ldata(i)/(4*head%irealf)
if(mdim1.lt.mlen) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
do i=1,dati%i-1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
enddo
i=dati%i
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dati%f)
if(nread.lt.iread) return
else
i=dati%i
call sigio_aldbti(head,i,dbti,iret)
if(iret.ne.0) return
call sigio_rrdbti(lu,head,dbti,iret)
if(iret.ne.0) return
dati%f(:mlen)=dbti%f(:mlen)
call sigio_axdbti(dbti,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdati(lu,head,dati,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dati),intent(in):: dati
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: mdim1
integer:: mlen
integer(8):: iskip,iwrite,nwrite
type(sigio_dbti):: dbti
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
i=dati%i
mdim1=size(dati%f,1)
iret=-5
if(i.lt.1.or.i.gt.head%ndata) return
mlen=head%ldata(i)/(4*head%irealf)
if(mdim1.lt.mlen) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.ne.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
do i=1,dati%i-1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
enddo
i=dati%i
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dati%f)
if(nwrite.lt.iwrite) return
iret=0
else
i=dati%i
call sigio_aldbti(head,i,dbti,iret)
if(iret.ne.0) return
dbti%f(:mlen)=dati%f(:mlen)
call sigio_rwdbti(lu,head,dbti,iret)
if(iret.ne.0) return
call sigio_axdbti(dbti,iret)
endif
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_aldbts(head,dbts,iret)
implicit none
type(sigio_head),intent(in):: head
type(sigio_dbts),intent(inout):: dbts
integer(sigio_intkind),intent(out):: iret
integer nc,dim1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! call sigio_axdbts(dbts,iret)
if(associated(dbts%hs)) call sigio_axdbts(dbts,iret)
nc=(head%jcap+1)*(head%jcap+2)
dim1=nc
allocate(dbts%hs(dim1),dbts%ps(dim1),stat=iret)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_axdbts(dbts,iret)
implicit none
type(sigio_dbts),intent(inout):: dbts
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
deallocate(dbts%hs,dbts%ps,stat=iret)
nullify(dbts%hs,dbts%ps)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_aldbtm(head,k1,k2,dbtm,iret)
implicit none
type(sigio_head),intent(in):: head
integer(sigio_intkind),intent(in):: k1,k2
type(sigio_dbtm),intent(inout):: dbtm
integer(sigio_intkind),intent(out):: iret
integer nc,dim1,dim3q
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! call sigio_axdbtm(dbtm,iret)
if(associated(dbtm%t)) call sigio_axdbtm(dbtm,iret)
iret=-3
if(k1.lt.1.or.k2.gt.head%levs) return
nc=(head%jcap+1)*(head%jcap+2)
dim1=nc
dim3q=head%ntrac
dbtm%k1=k1
dbtm%k2=k2
allocate(dbtm%t(dim1,k1:k2),dbtm%d(dim1,k1:k2),dbtm%z(dim1,k1:k2),&
dbtm%q(dim1,k1:k2,dim3q),stat=iret)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_axdbtm(dbtm,iret)
implicit none
type(sigio_dbtm),intent(inout):: dbtm
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
dbtm%k1=0
dbtm%k2=0
deallocate(dbtm%t,dbtm%d,dbtm%z,dbtm%q,stat=iret)
nullify(dbtm%t,dbtm%d,dbtm%z,dbtm%q)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_aldbti(head,i,dbti,iret)
implicit none
type(sigio_head),intent(in):: head
integer(sigio_intkind),intent(in):: i
type(sigio_dbti),intent(inout):: dbti
integer(sigio_intkind),intent(out):: iret
integer dim1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! call sigio_axdbti(dbti,iret)
if(associated(dbti%f)) call sigio_axdbti(dbti,iret)
iret=-3
if(i.lt.1.or.i.gt.head%ndata) return
dim1=head%ldata(i)/(4*head%irealf)
dbti%i=i
allocate(dbti%f(dim1),stat=iret)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_axdbti(dbti,iret)
implicit none
type(sigio_dbti),intent(inout):: dbti
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
dbti%i=0
deallocate(dbti%f,stat=iret)
nullify(dbti%f)
if(iret.ne.0) iret=-3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdbta(lu,head,dbta,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbta),intent(inout):: dbta
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,mdim1,mdim2,mdim3q
integer(8):: iskip,iread,nread
type(sigio_data):: data
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(dbta%hs,1),size(dbta%ps,1),&
size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),&
size(dbta%q,1))
mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),&
size(dbta%q,2))
mdim3q=size(dbta%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc.or.&
mdim2.lt.head%levs.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%hs)
if(nread.lt.iread) return
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%ps)
if(nread.lt.iread) return
do k=1,head%levs
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%t(1,k))
if(nread.lt.iread) return
enddo
do k=1,head%levs
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%d(1,k))
if(nread.lt.iread) return
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%z(1,k))
if(nread.lt.iread) return
enddo
do n=1,head%ntrac
do k=1,head%levs
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%q(1,k,n))
if(nread.lt.iread) return
enddo
enddo
do n=1,head%nxgr
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%xgr(1,1,n))
if(nread.lt.iread) return
enddo
if(head%nxss.gt.0) then
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbta%xss)
if(nread.lt.iread) return
endif
else
call sigio_aldata(head,data,iret)
if(iret.ne.0) return
call sigio_rrdata(lu,head,data,iret)
if(iret.ne.0) return
dbta%hs(:nc)=data%hs(:nc)
dbta%ps(:nc)=data%ps(:nc)
dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs)
dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs)
dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs)
dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac)
dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=&
data%xgr(:head%lonb,:head%latb,:head%nxgr)
dbta%xss(:head%nxss)=data%xss(:head%nxss)
call sigio_axdata(data,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdbta(lu,head,dbta,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbta),intent(in):: dbta
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,mdim1,mdim2,mdim3q
integer(8):: iskip,iwrite,nwrite
type(sigio_data):: data
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(dbta%hs,1),size(dbta%ps,1),&
size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),&
size(dbta%q,1))
mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),&
size(dbta%q,2))
mdim3q=size(dbta%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc.or.&
mdim2.lt.head%levs.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%hs)
if(nwrite.lt.iwrite) return
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%ps)
if(nwrite.lt.iwrite) return
do k=1,head%levs
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%t(1,k))
if(nwrite.lt.iwrite) return
enddo
do k=1,head%levs
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%d(1,k))
if(nwrite.lt.iwrite) return
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%z(1,k))
if(nwrite.lt.iwrite) return
enddo
do n=1,head%ntrac
do k=1,head%levs
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%q(1,k,n))
if(nwrite.lt.iwrite) return
enddo
enddo
do n=1,head%nxgr
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%xgr(1,1,n))
if(nwrite.lt.iwrite) return
enddo
if(head%nxss.gt.0) then
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbta%xss)
if(nwrite.lt.iwrite) return
endif
else
call sigio_aldata(head,data,iret)
if(iret.ne.0) return
data%hs(:nc)=dbta%hs(:nc)
data%ps(:nc)=dbta%ps(:nc)
data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs)
data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs)
data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs)
data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac)
data%xgr(:head%lonb,:head%latb,:head%nxgr)=&
dbta%xgr(:head%lonb,:head%latb,:head%nxgr)
data%xss(:head%nxss)=dbta%xss(:head%nxss)
call sigio_rwdata(lu,head,data,iret)
if(iret.ne.0) return
call sigio_axdata(data,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrohdcb(lu,cfname,head,dbta,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
type(sigio_head),intent(inout):: head
type(sigio_dbta),intent(inout):: dbta
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rropen(lu,cfname,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rrhead(lu,head,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_aldbta(head,dbta,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rrdbta(lu,head,dbta,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rclose(lu,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwohdcb(lu,cfname,head,dbta,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
character*(*),intent(in):: cfname
type(sigio_head),intent(inout):: head
type(sigio_dbta),intent(in):: dbta
integer(sigio_intkind),intent(out):: iret
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rwopen(lu,cfname,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rwhead(lu,head,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rwdbta(lu,head,dbta,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
call sigio_rclose(lu,iret)
if(iret.ne.0) return
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdbts(lu,head,dbts,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbts),intent(inout):: dbts
integer(sigio_intkind),intent(out):: iret
integer:: i
integer:: nc,mdim1
integer(8):: iskip,iread,nread
type(sigio_dats):: dats
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(dbts%hs,1),size(dbts%ps,1))
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbts%hs)
if(nread.lt.iread) return
i=i+1
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbts%ps)
if(nread.lt.iread) return
else
call sigio_aldats(head,dats,iret)
if(iret.ne.0) return
call sigio_rrdats(lu,head,dats,iret)
if(iret.ne.0) return
dbts%hs(:nc)=dats%hs(:nc)
dbts%ps(:nc)=dats%ps(:nc)
call sigio_axdats(dats,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdbts(lu,head,dbts,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbts),intent(in):: dbts
integer(sigio_intkind),intent(out):: iret
integer:: i
integer:: nc,mdim1
integer(8):: iskip,iwrite,nwrite
type(sigio_dats):: dats
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
mdim1=min(size(dbts%hs,1),size(dbts%ps,1))
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(mdim1.lt.nc) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbts%hs)
if(nwrite.lt.iwrite) return
i=i+1
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbts%ps)
if(nwrite.lt.iwrite) return
else
call sigio_aldats(head,dats,iret)
if(iret.ne.0) return
dats%hs(:nc)=dbts%hs(:nc)
dats%ps(:nc)=dbts%ps(:nc)
call sigio_rwdats(lu,head,dats,iret)
if(iret.ne.0) return
call sigio_axdats(dats,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdbtm(lu,head,dbtm,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbtm),intent(inout):: dbtm
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q
integer(8):: iskip,iread,nread
type(sigio_datm):: datm
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
k1=dbtm%k1
k2=dbtm%k2
mdim1=min(size(dbtm%t,1),size(dbtm%d,1),size(dbtm%z,1),&
size(dbtm%q,1))
ldim2=max(lbound(dbtm%t,2),lbound(dbtm%d,2),lbound(dbtm%z,2),&
lbound(dbtm%q,2))
udim2=min(ubound(dbtm%t,2),ubound(dbtm%d,2),ubound(dbtm%z,2),&
ubound(dbtm%q,2))
mdim3q=size(dbtm%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(k1.lt.1.or.k2.gt.head%levs.or.&
mdim1.lt.nc.or.&
ldim2.gt.k1.or.udim2.lt.k2.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbtm%t(1,k))
if(nread.lt.iread) return
iskip=iskip+nread
endif
enddo
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbtm%d(1,k))
if(nread.lt.iread) return
iskip=iskip+nread
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbtm%z(1,k))
if(nread.lt.iread) return
iskip=iskip+nread
endif
enddo
do n=1,head%ntrac
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbtm%q(1,k,n))
if(nread.lt.iread) return
iskip=iskip+nread
endif
enddo
enddo
else
call sigio_aldatm(head,k1,k2,datm,iret)
if(iret.ne.0) return
call sigio_rrdatm(lu,head,datm,iret)
if(iret.ne.0) return
dbtm%t(:nc,k1:k2)=datm%t(:nc,k1:k2)
dbtm%d(:nc,k1:k2)=datm%d(:nc,k1:k2)
dbtm%z(:nc,k1:k2)=datm%z(:nc,k1:k2)
dbtm%q(:nc,k1:k2,:head%ntrac)=datm%q(:nc,k1:k2,:head%ntrac)
call sigio_axdatm(datm,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdbtm(lu,head,dbtm,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbtm),intent(in):: dbtm
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q
integer(8):: iskip,iwrite,nwrite
type(sigio_datm):: datm
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
k1=dbtm%k1
k2=dbtm%k2
mdim1=min(size(dbtm%t,1),size(dbtm%d,1),size(dbtm%z,1),&
size(dbtm%q,1))
ldim2=max(lbound(dbtm%t,2),lbound(dbtm%d,2),lbound(dbtm%z,2),&
lbound(dbtm%q,2))
udim2=min(ubound(dbtm%t,2),ubound(dbtm%d,2),ubound(dbtm%z,2),&
ubound(dbtm%q,2))
mdim3q=size(dbtm%q,3)
nc=(head%jcap+1)*(head%jcap+2)
iret=-5
if(k1.lt.1.or.k2.gt.head%levs.or.&
mdim1.lt.nc.or.&
ldim2.gt.k1.or.udim2.lt.k2.or.&
mdim3q.lt.head%ntrac) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
i=1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbtm%t(1,k))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
endif
enddo
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbtm%d(1,k))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbtm%z(1,k))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
endif
enddo
do n=1,head%ntrac
do k=1,head%levs
if(k.lt.k1.or.k.gt.k2) then
i=i+1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
else
i=i+1
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbtm%q(1,k,n))
if(nwrite.lt.iwrite) return
iskip=iskip+nwrite
endif
enddo
enddo
else
call sigio_aldatm(head,k1,k2,datm,iret)
if(iret.ne.0) return
datm%t(:nc,k1:k2)=dbtm%t(:nc,k1:k2)
datm%d(:nc,k1:k2)=dbtm%d(:nc,k1:k2)
datm%z(:nc,k1:k2)=dbtm%z(:nc,k1:k2)
datm%q(:nc,k1:k2,:head%ntrac)=dbtm%q(:nc,k1:k2,:head%ntrac)
call sigio_rwdatm(lu,head,datm,iret)
if(iret.ne.0) return
call sigio_axdatm(datm,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rrdbti(lu,head,dbti,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbti),intent(inout):: dbti
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: mdim1
integer:: mlen
integer(8):: iskip,iread,nread
type(sigio_dati):: dati
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
i=dbti%i
mdim1=size(dbti%f,1)
iret=-5
if(i.lt.1.or.i.gt.head%ndata) return
mlen=head%ldata(i)/(4*head%irealf)
if(mdim1.lt.mlen) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
do i=1,dbti%i-1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
enddo
i=dbti%i
iread=head%ldata(i)
call bafrreadl(lu,iskip,iread,nread,dbti%f)
if(nread.lt.iread) return
else
i=dbti%i
call sigio_aldati(head,i,dati,iret)
if(iret.ne.0) return
call sigio_rrdati(lu,head,dati,iret)
if(iret.ne.0) return
dbti%f(:mlen)=dati%f(:mlen)
call sigio_axdati(dati,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
subroutine sigio_rwdbti(lu,head,dbti,iret)
implicit none
integer(sigio_intkind),intent(in):: lu
type(sigio_head),intent(in):: head
type(sigio_dbti),intent(in):: dbti
integer(sigio_intkind),intent(out):: iret
integer:: i,k,n
integer:: mdim1
integer:: mlen
integer(8):: iskip,iwrite,nwrite
type(sigio_dati):: dati
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
i=dbti%i
mdim1=size(dbti%f,1)
iret=-5
if(i.lt.1.or.i.gt.head%ndata) return
mlen=head%ldata(i)/(4*head%irealf)
if(mdim1.lt.mlen) return
iret=-4
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if(head%irealf.eq.2) then
iskip=0
do i=1,head%nhead
call bafrindexl(0,iskip,int(head%lhead(i),8),iskip)
enddo
do i=1,dbti%i-1
call bafrindexl(0,iskip,int(head%ldata(i),8),iskip)
enddo
i=dbti%i
iwrite=head%ldata(i)
call bafrwritel(lu,iskip,iwrite,nwrite,dbti%f)
if(nwrite.lt.iwrite) return
else
i=dbti%i
call sigio_aldati(head,i,dati,iret)
if(iret.ne.0) return
dati%f(:mlen)=dbti%f(:mlen)
call sigio_rwdati(lu,head,dati,iret)
if(iret.ne.0) return
call sigio_axdati(dati,iret)
endif
iret=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
end subroutine
!-------------------------------------------------------------------------------
end module