!---------------------------------------------------------------------------- module nemsio_module !$$$ module document block ! ! module: nemsio_module API for NEMS input/output ! ! Abstract: This module handles NEMS input/output ! ! Program history log ! 2006-11-10 Jun Wang for gfsio ! 2008-02-29 Jun Wang ! 2008-11-04 Jun Wang - Changes to NFRAME; users can output fewer ! metadata records and update data fields in ! existing files. ! 2009-03-31 Jun Wang - use new bacio to handle >2gb file, changed ! record name to 16 characters ! 2009-04-28 Jun Wang - allow user to update meta data for date, forecast time ! ! Public Variables ! Public Defined Types ! nemsio_gfile ! private ! gtype: character(nemsio_charkind8) NEMSIO file identifier ! gdatatype:character(nemsio_charkind8) data format ! modelname:character(nemsio_charkind8) modelname ! version: integer(nemsio_intkind) verion number ! nmeta: integer(nemsio_intkind) number of metadata rec ! lmeta: integer(nemsio_intkind) length of metadata rec 2 for model paramodels ! nrec: integer(nemsio_intkind) number of data rec ! idate(1:7):integer(nemsio_intkind) initial date (yyyy/mm/dd/hh/mm/ssn/ssd) ! nfday: integer(nemsio_intkind) forecast day ! nfhour: integer(nemsio_intkind) forecast hour ! nfminute:integer(nemsio_intkind) forecast minutes ! nfsecondn:integer(nemsio_intkind) numerator of forecast second fraction ! nfsecondd:integer(nemsio_intkind) denominator of forecast second fraction ! dimy: integer(nemsio_intkind) dimension in latitude ! dimx: integer(nemsio_intkind) dimension in Longitude ! dimz: integer(nemsio_intkind) number of levels ! nframe: integer(nemsio_intkind) dimension of halo ! nsoil: integer(nemsio_intkind) number of soil layers ! ntrac: integer(nemsio_intkind) number of tracers ! jcap: integer(nemsio_intkind) spectral truncation ! ncldt: integer(nemsio_intkind) number of cloud types ! idsl: integer(nemsio_intkind) semi-lagrangian id ! idvc: integer(nemsio_intkind) vertical coordinate id ! idvm: integer(nemsio_intkind) mass variable id ! idrt: integer(nemsio_intkind) grid identifier ! (idrt=4 for gaussian grid, ! idrt=0 for equally-spaced grid including poles, ! idrt=256 for equally-spaced grid excluding poles) ! rlon_min:real(nemsio_realkind) minimal longtitude of regional domain (global:set to 0) ! rlon_max:real(nemsio_realkind) maximal longtitude of regional domain (global:set to 360.) ! rlat_min:real(nemsio_realkind) minimal longtitude of regional domain (global:set to -90) ! rlat_max:real(nemsio_realkind) maximal longtitude of regional domain (global:set to 90) ! extrameta:logical(nemsio_logickind)extra meta data flag ! nmetavari:integer(nemsio_intkind) number of extra meta data integer variables ! nmetavarr:integer(nemsio_intkind) number of extra meta data real variables ! nmetavarl:integer(nemsio_intkind) number of extra meta data logical variables ! nmetavarc:integer(nemsio_intkind) number of extra meta data character variables ! nmetaaryi:integer(nemsio_intkind) number of extra meta data integer arrays ! nmetaaryr:integer(nemsio_intkind) number of extra meta data real arrays ! nmetaaryl:integer(nemsio_intkind) number of extra meta data logical arrays ! nmetaaryc:integer(nemsio_intkind) number of extra meta data character arrays ! ! recname: character(nemsio_charkind),allocatable recname(:) ! reclevtyp: character(nemsio_charkind),allocatable reclevtyp(:) ! reclev: integer(nemsio_intkind),allocatable reclev(:) ! vcoord: real(nemsio_realkind),allocatable vcoord(:,:,:) ! lat: real(nemsio_realkind),allocatable lat(:) lat for mess point ! lon: real(nemsio_realkind),allocatable lon(:) lon for mess point ! gvlat1d: real(nemsio_realkind),allocatable gvlat1d(:) lat for wind point ! gvlon1d: real(nemsio_realkind),allocatable gvlon1d(:) lon for wind point ! Cpi: real(nemsio_realkind),allocatable cpi(:) ! Ri: real(nemsio_realkind),allocatable ri(:) ! ! variname:character(nemsio_charkind) names of extra meta data integer variables ! varrname:character(nemsio_charkind) names of extra meta data real variables ! varlname:character(nemsio_charkind) names of extra meta data logical variables ! varcname:character(nemsio_charkind) names of extra meta data character variables ! varival: integer(nemsio_intkind) values of extra meta data integer variables ! varrval: real(nemsio_realkind) values of extra meta data integer variables ! varlval: logical(nemsio_logickind) values of extra meta data integer variables ! varcval: character(nemsio_charkind) values of extra meta data integer variables ! aryiname:character(nemsio_charkind) names of extra meta data integer arrays ! aryrname:character(nemsio_charkind) names of extra meta data real arrays ! arylname:character(nemsio_charkind) names of extra meta data logical arrays ! arycname:character(nemsio_charkind) names of extra meta data character arrays ! aryilen: integer(nemsio_intkind) lengths of extra meta data integer arrays ! aryilen: integer(nemsio_intkind) number of extra meta data integer arrays ! aryilen: integer(nemsio_intkind) number of extra meta data integer arrays !!--- file handler ! gfname: character(255) file name ! gaction: character(nemsio_charkind) read/write ! flunit: integer(nemsio_intkind) unit number ! ! Public method ! nemsio_init ! nemsio_finalize ! nemsio_open ! nemsio_writerec ! nemsio_readirec ! nemsio_writerecv ! nemsio_readirecv ! nemsio_writerecw34 ! nemsio_readirecw34 ! nemsio_writerecvw34 ! nemsio_readirecvw34 ! nemsio_close ! nemsio_getfilehead ! nemsio_getrechead ! Possible return code ! 0 Successful call ! -1 Open or close I/O error ! -2 array size ! -3 Meta data I/O error (possible EOF) ! -4 GETGB/PUTGB error ! -5 Search record or set GRIB message info error ! -6 allocate/deallocate error ! -7 set grib table ! -8 file meta data initialization (default:1152*576) ! -9 NOT nemsio type file ! -10 get/close file unit ! -11 read/write bin data ! -12 read/write NMM B grid lat lon ! -13 read/write NMM sfc var ! -15 read/write gsi ! -17 get var from file header ! !$$$ end module document block ! use kinds, only: r_single,r_kind,i_kind,i_llong use constants, only: izero,ione,zero,quarter,half,one,two,four implicit none private !------------------------------------------------------------------------------ ! private variables and type needed by nemsio_gfile integer(i_kind),parameter:: nemsio_lmeta1=48_i_kind,nemsio_lmeta3=32_i_kind integer(i_kind),parameter:: nemsio_charkind=16_i_kind,nemsio_charkind8=8_i_kind integer(i_kind),parameter:: nemsio_logickind=4_i_kind integer(i_kind),parameter :: nemsio_intfill=-9999_i_kind integer(i_llong),parameter :: nemsio_intfill8=-9999_i_llong logical(nemsio_logickind),parameter:: nemsio_logicfill=.false. real(i_kind),parameter :: nemsio_kpds_intfill=-ione real(r_single),parameter :: nemsio_realfill=-9999._r_single !for grib real(r_single),parameter :: nemsio_undef_grb=9.E20_r_single ! !------------------------------------------------------------------------------ !--- public types type,public :: nemsio_gfile private character(nemsio_charkind8) :: gtype=' ' integer(i_kind) :: version=nemsio_intfill character(nemsio_charkind8) :: gdatatype=' ' character(nemsio_charkind8) :: modelname=' ' integer(i_kind) :: nmeta=nemsio_intfill integer(i_kind) :: lmeta=nemsio_intfill integer(i_kind) :: nrec=nemsio_intfill ! integer(i_kind):: idate(7)=nemsio_intfill integer(i_kind):: nfday=nemsio_intfill integer(i_kind):: nfhour=nemsio_intfill integer(i_kind):: nfminute=nemsio_intfill integer(i_kind):: nfsecondn=nemsio_intfill integer(i_kind):: nfsecondd=nemsio_intfill ! integer(i_kind):: ifdate(7)=nemsio_intfill ! integer(i_kind):: dimx=nemsio_intfill integer(i_kind):: dimy=nemsio_intfill integer(i_kind):: dimz=nemsio_intfill integer(i_kind):: nframe=nemsio_intfill integer(i_kind):: nsoil=nemsio_intfill integer(i_kind):: ntrac=nemsio_intfill ! integer(i_kind) :: jcap=nemsio_intfill integer(i_kind) :: ncldt=nemsio_intfill integer(i_kind) :: idvc=nemsio_intfill integer(i_kind) :: idsl=nemsio_intfill integer(i_kind) :: idvm=nemsio_intfill integer(i_kind) :: idrt=nemsio_intfill real(r_single) :: rlon_min=nemsio_realfill real(r_single) :: rlon_max=nemsio_realfill real(r_single) :: rlat_min=nemsio_realfill real(r_single) :: rlat_max=nemsio_realfill logical(nemsio_logickind) :: extrameta=nemsio_logicfill ! integer(i_kind):: nmetavari=nemsio_intfill integer(i_kind):: nmetavarr=nemsio_intfill integer(i_kind):: nmetavarl=nemsio_intfill integer(i_kind):: nmetavarc=nemsio_intfill integer(i_kind):: nmetaaryi=nemsio_intfill integer(i_kind):: nmetaaryr=nemsio_intfill integer(i_kind):: nmetaaryl=nemsio_intfill integer(i_kind):: nmetaaryc=nemsio_intfill ! character(nemsio_charkind),allocatable :: recname(:) character(nemsio_charkind),allocatable :: reclevtyp(:) integer(i_kind),allocatable :: reclev(:) ! real(r_single),allocatable :: vcoord(:,:,:) real(r_single),allocatable :: lat(:) real(r_single),allocatable :: lon(:) real(r_single),allocatable :: dx(:) real(r_single),allocatable :: dy(:) ! real(r_single),allocatable :: Cpi(:) real(r_single),allocatable :: Ri(:) ! character(nemsio_charkind),allocatable :: variname(:) integer(i_kind),allocatable :: varival(:) character(nemsio_charkind),allocatable :: varrname(:) real(r_single),allocatable :: varrval(:) character(nemsio_charkind),allocatable :: varlname(:) logical(nemsio_logickind),allocatable :: varlval(:) character(nemsio_charkind),allocatable :: varcname(:) character(nemsio_charkind),allocatable :: varcval(:) ! character(nemsio_charkind),allocatable :: aryiname(:) integer(i_kind),allocatable :: aryilen(:) integer(i_kind),allocatable :: aryival(:,:) character(nemsio_charkind),allocatable :: aryrname(:) integer(i_kind),allocatable :: aryrlen(:) real(r_single),allocatable :: aryrval(:,:) character(nemsio_charkind),allocatable :: arylname(:) integer(i_kind),allocatable :: aryllen(:) logical(nemsio_logickind),allocatable :: arylval(:,:) character(nemsio_charkind),allocatable :: arycname(:) integer(i_kind),allocatable :: aryclen(:) character(nemsio_charkind),allocatable :: arycval(:,:) ! character(255) :: gfname character(nemsio_charkind8) :: gaction integer(i_llong) :: tlmeta=nemsio_intfill integer(i_kind) :: fieldsize=nemsio_intfill integer(i_kind) :: flunit=nemsio_intfill integer(i_kind) :: headvarinum=nemsio_intfill integer(i_kind) :: headvarrnum=nemsio_intfill integer(i_kind) :: headvarcnum=nemsio_intfill integer(i_kind) :: headvarlnum=nemsio_intfill integer(i_kind) :: headaryinum=nemsio_intfill integer(i_kind) :: headaryrnum=nemsio_intfill integer(i_kind) :: headarycnum=nemsio_intfill character(nemsio_charkind),allocatable :: headvarcname(:) character(nemsio_charkind),allocatable :: headvariname(:) character(nemsio_charkind),allocatable :: headvarrname(:) character(nemsio_charkind),allocatable :: headvarlname(:) character(nemsio_charkind),allocatable :: headaryiname(:) character(nemsio_charkind),allocatable :: headaryrname(:) character(nemsio_charkind),allocatable :: headarycname(:) integer(i_kind),allocatable :: headvarival(:) real(r_single),allocatable :: headvarrval(:) character(nemsio_charkind),allocatable :: headvarcval(:) logical(nemsio_logickind),allocatable :: headvarlval(:) integer(i_kind),allocatable :: headaryival(:,:) real(r_single),allocatable :: headaryrval(:,:) character(nemsio_charkind),allocatable :: headarycval(:,:) character,allocatable :: cbuf(:) integer(i_kind) :: mbuf=izero,nlen,nnum,mnum integer(i_llong) :: tlmetalat=nemsio_intfill integer(i_llong) :: tlmetalon=nemsio_intfill integer(i_llong) :: tlmetadx=nemsio_intfill integer(i_llong) :: tlmetady=nemsio_intfill integer(i_llong) :: tlmetavarival=nemsio_intfill integer(i_llong) :: tlmetaaryival=nemsio_intfill end type nemsio_gfile ! !------------------------------------------------------------------------------ !--- private types type :: nemsio_meta1 sequence character(nemsio_charkind8) :: gtype character(nemsio_charkind8) :: modelname character(nemsio_charkind8) :: gdatatype integer(i_kind) :: version,nmeta,lmeta integer(i_kind) :: reserve(3) end type nemsio_meta1 ! type :: nemsio_meta2 sequence integer(i_kind) :: nrec integer(i_kind) :: idate(1:7),nfday,nfhour,nfminute,nfsecondn, & nfsecondd,dimx,dimy,dimz,nframe,nsoil,ntrac,& jcap,ncldt,idvc,idsl,idvm,idrt real(r_single) :: rlon_min,rlon_max,rlat_min,rlat_max logical(nemsio_logickind) :: extrameta end type nemsio_meta2 ! type :: nemsio_meta3 integer(i_kind) :: nmetavari,nmetavarr,nmetavarl,nmetavarc, & nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc end type nemsio_meta3 ! type :: nemsio_grbmeta integer(i_kind) :: jf=nemsio_intfill integer(i_kind) :: j=nemsio_kpds_intfill integer(i_kind) :: jpds(200)=nemsio_kpds_intfill integer(i_kind) :: jgds(200)=nemsio_kpds_intfill logical*1,allocatable :: lbms(:) end type nemsio_grbmeta ! type :: nemsio_grbtbl_item character(nemsio_charkind) :: shortname=' ' character(nemsio_charkind*2) :: leveltype=' ' integer(i_kind) :: precision,g1lev,g1param,g1level end type nemsio_grbtbl_item ! type :: nemsio_grbtbl integer(i_kind) :: iptv type(nemsio_grbtbl_item) :: item(255) end type nemsio_grbtbl ! type(nemsio_grbtbl),save :: gribtable(10) ! !----- interface interface nemsio_getheadvar module procedure nemsio_getfheadvari module procedure nemsio_getfheadvarr module procedure nemsio_getfheadvarl module procedure nemsio_getfheadvarc module procedure nemsio_getfheadaryi module procedure nemsio_getfheadaryr module procedure nemsio_getfheadaryl module procedure nemsio_getfheadaryc end interface nemsio_getheadvar ! interface nemsio_setheadvar module procedure nemsio_setfheadvari module procedure nemsio_setfheadaryi end interface nemsio_setheadvar ! interface nemsio_readrec module procedure nemsio_readrec4 module procedure nemsio_readrec8 end interface nemsio_readrec ! interface nemsio_readrecv module procedure nemsio_readrecv4 module procedure nemsio_readrecv8 end interface nemsio_readrecv ! interface nemsio_writerec module procedure nemsio_writerec4 module procedure nemsio_writerec8 end interface nemsio_writerec ! interface nemsio_writerecv module procedure nemsio_writerecv4 module procedure nemsio_writerecv8 end interface nemsio_writerecv ! interface splat module procedure nemsio_splat4 module procedure nemsio_splat8 end interface splat ! interface nemsio_readrecbin4 module procedure nemsio_readrecbin4d4 module procedure nemsio_readrecbin4d8 end interface nemsio_readrecbin4 ! interface nemsio_readrecbin8 module procedure nemsio_readrecbin8d4 module procedure nemsio_readrecbin8d8 end interface nemsio_readrecbin8 ! interface nemsio_readrecvbin4 module procedure nemsio_readrecvbin4d4 module procedure nemsio_readrecvbin4d8 end interface nemsio_readrecvbin4 ! interface nemsio_readrecvbin8 module procedure nemsio_readrecvbin8d4 module procedure nemsio_readrecvbin8d8 end interface nemsio_readrecvbin8 ! interface nemsio_writerecbin4 module procedure nemsio_writerecbin4d4 module procedure nemsio_writerecbin4d8 end interface nemsio_writerecbin4 ! interface nemsio_writerecbin8 module procedure nemsio_writerecbin8d4 module procedure nemsio_writerecbin8d8 end interface nemsio_writerecbin8 ! interface nemsio_writerecvbin4 module procedure nemsio_writerecvbin4d4 module procedure nemsio_writerecvbin4d8 end interface nemsio_writerecvbin4 ! interface nemsio_writerecvbin8 module procedure nemsio_writerecvbin8d4 module procedure nemsio_writerecvbin8d8 end interface nemsio_writerecvbin8 ! !--- file unit for putgb/getgb ---- integer(i_kind),save :: fileunit(600:699)=izero !------------------------------------------------------------------------------ !public methods public nemsio_undef_grb public nemsio_charkind,nemsio_charkind8,nemsio_logickind public nemsio_init,nemsio_finalize,nemsio_open,nemsio_close public nemsio_readrec,nemsio_writerec,nemsio_readrecv,nemsio_writerecv public nemsio_readrecw34,nemsio_writerecw34,nemsio_readrecvw34,nemsio_writerecvw34 public nemsio_getfilehead,nemsio_getheadvar,nemsio_getrechead public nemsio_setfilehead,nemsio_setheadvar ! contains !------------------------------------------------------------------------------- subroutine nemsio_init(iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_init ! prgmmr: ! ! abstract: set grib table ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! initialization !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: ios call nemsio_setgrbtbl(ios) if ( present(iret)) iret=ios if ( ios/=izero) then if (present(iret)) return call nemsio_stop endif ! end subroutine nemsio_init !------------------------------------------------------------------------------ subroutine nemsio_finalize() !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_finalize ! prgmmr: ! ! abstract: finalization ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none end subroutine nemsio_finalize !------------------------------------------------------------------------------ subroutine nemsio_open(gfile,gfname,gaction,iret,gdatatype,version, & nmeta,lmeta,modelname,nrec,idate,nfday,nfhour, & nfminute,nfsecondn,nfsecondd, & dimx,dimy,dimz,nframe,nsoil,ntrac,jcap,ncldt,idvc,idsl,idvm,idrt, & rlon_min,rlon_max,rlat_min,rlat_max,extrameta, & nmetavari,nmetavarr,nmetavarl, & nmetaaryi,nmetaaryr,nmetaaryl, & recname,reclevtyp,reclev,vcoord,lat,lon,dx,dy,cpi,ri, & variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, & aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, & arylname,aryllen,arylval,arycname,aryclen,arycval ) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_open ! prgmmr: ! ! abstract: open nemsio file, and read/write the meta data ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! gfname ! gaction ! gdatatype,modelname ! version,nmeta,lmeta,nrec ! idate(7),nfday,nfhour ! nfminute, nfsecondn,nfsecondd ! dimx,dimy,dimz,nframe ! nsoil,ntrac ! jcap,ncldt,idvc,idsl ! idvm,idrt ! rlat_min,rlat_max ! rlon_min,rlon_max ! extrameta ! nmetavari,nmetavarr ! nmetavarl,nmetaaryi,nmetaaryr,nmetaaryl ! recname,reclevtyp ! reclev ! vcoord ! lat,lon ! dx,dy ! Cpi,Ri ! variname,varrname ! varlname,varcname,aryiname,aryrname,arylname,arycname ! aryilen,aryrlen ! aryllen,aryclen ! varival,aryival ! varrval,aryrval ! varlval,arylval ! varcval,arycval ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(inout) :: gfile character*(*) ,intent(in ) :: gfname character*(*) ,intent(in ) :: gaction !------------------------------------------------------------------------------- ! optional variables !------------------------------------------------------------------------------- integer(i_kind) ,optional,intent( out) :: iret character*(*) ,optional,intent(in ) :: gdatatype,modelname integer(i_kind) ,optional,intent(in ) :: version,nmeta,lmeta,nrec integer(i_kind) ,optional,intent(in ) :: idate(7),nfday,nfhour, & nfminute, nfsecondn,nfsecondd integer(i_kind) ,optional,intent(in ) :: dimx,dimy,dimz,nframe, & nsoil,ntrac integer(i_kind) ,optional,intent(in ) :: jcap,ncldt,idvc,idsl, & idvm,idrt real(r_single) ,optional,intent(in ) :: rlat_min,rlat_max, & rlon_min,rlon_max logical(nemsio_logickind),optional,intent(in ) :: extrameta integer(i_kind) ,optional,intent(in ) :: nmetavari,nmetavarr, & nmetavarl,nmetaaryi,nmetaaryr,nmetaaryl ! character*(*) ,optional,intent(in ) :: recname(:),reclevtyp(:) integer(i_kind) ,optional,intent(in ) :: reclev(:) real(r_single) ,optional,intent(in ) :: vcoord(:,:,:) real(r_single) ,optional,intent(in ) :: lat(:),lon(:) real(r_single) ,optional,intent(in ) :: dx(:),dy(:) real(r_single) ,optional,intent(in ) :: Cpi(:),Ri(:) ! character*(*) ,optional,intent(in ) :: variname(:),varrname(:),& varlname(:),varcname(:),aryiname(:),aryrname(:),arylname(:),arycname(:) integer(i_kind) ,optional,intent(in ) :: aryilen(:),aryrlen(:), & aryllen(:),aryclen(:) integer(i_kind) ,optional,intent(in ) :: varival(:),aryival(:,:) real(r_single) ,optional,intent(in ) :: varrval(:),aryrval(:,:) logical(nemsio_logickind),optional,intent(in ) :: varlval(:),arylval(:,:) character(*) ,optional,intent(in ) :: varcval(:),arycval(:,:) ! integer(i_kind) :: ios !------------------------------------------------------------ ! assign a unit number !------------------------------------------------------------ if (present(iret)) iret=-ione call nemsio_getlu(gfile,gfname,gaction,ios) if ( ios/=izero ) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif !------------------------------------------------------------ ! open and read meta data for READ !------------------------------------------------------------ ! print *,'in rcreate, gfname=',gfname,'gaction=',lowercase(gaction) if ( equal_str_nocase(trim(gaction),'read') .or. equal_str_nocase(trim(gaction),'rdwr')) then if ( equal_str_nocase(trim(gaction),'read') )then call baopenr(gfile%flunit,gfname,ios) if ( ios/=izero) then if ( present(iret)) then return else call nemsio_stop endif endif else call baopen(gfile%flunit,gfname,ios) if ( ios/=izero) then if ( present(iret)) then return else call nemsio_stop endif endif endif ! print *,'open read file=',gfname ! ! read meta data for gfile ! call nemsio_rcreate(gfile,ios) if ( ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! !set grib index buf ! if(gfile%gdatatype=='grib') then gfile%mbuf=256*1024 gfile%nnum=izero gfile%nlen=izero gfile%mnum=-ione if(allocated(gfile%cbuf)) deallocate(gfile%cbuf) allocate(gfile%cbuf(gfile%mbuf)) endif !------------------------------------------------------------ ! open and write meta data for WRITE !------------------------------------------------------------ elseif ( equal_str_nocase(trim(gaction),'write') ) then call baopenwt(gfile%flunit,gfname,ios) if ( ios/=izero) then if ( present(iret)) then return else call nemsio_stop endif endif call nemsio_wcreate(gfile,ios,gdatatype=gdatatype, & version=version, nmeta=nmeta,lmeta=lmeta,modelname=modelname, & nrec=nrec,idate=idate,nfday=nfday,nfhour=nfhour,nfminute=nfminute,& nfsecondn=nfsecondn, nfsecondd=nfsecondd, & dimx=dimx,dimy=dimy,dimz=dimz,nframe=nframe,nsoil=nsoil, & ntrac=ntrac,jcap=jcap,ncldt=ncldt,idvc=idvc,idsl=idsl, & idvm=idvm,idrt=idrt, & rlon_min=rlon_min,rlon_max=rlon_max,rlat_min=rlat_min, & rlat_max=rlat_max,extrameta=extrameta, & nmetavari=nmetavari,nmetavarr=nmetavarr, & nmetavarl=nmetavarl,nmetaaryi=nmetaaryi,nmetaaryr=nmetaaryr,& nmetaaryl=nmetaaryl,recname=recname,reclevtyp=reclevtyp, & reclev=reclev,vcoord=vcoord,lat=lat,lon=lon,dx=dx,dy=dy, & cpi=cpi,ri=ri,variname=variname,varival=varival,varrname=varrname,& varrval=varrval,varlname=varlname,varlval=varlval, & varcname=varcname,varcval=varcval, & aryiname=aryiname,aryilen=aryilen,aryival=aryival, & aryrname=aryrname,aryrlen=aryrlen,aryrval=aryrval, & arylname=arylname,aryllen=aryllen,arylval=arylval, & arycname=arycname,aryclen=aryclen,arycval=arycval ) if ( ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif !------------------------------------------------------------ ! if gaction is wrong !------------------------------------------------------------ else if ( present(iret)) then return else call nemsio_stop endif endif !------------------------------------------------------------ ! set default header !------------------------------------------------------------ if(.not.allocated(gfile%headvariname).or. & .not.allocated(gfile%headvarrname).or. & .not.allocated(gfile%headvarcname).or. & .not.allocated(gfile%headvarlname).or. & .not.allocated(gfile%headaryiname).or. & .not.allocated(gfile%headaryrname) ) then call nemsio_setfhead(gfile,ios) if ( present(iret)) iret=ios if ( ios/=izero) then if (present(iret)) return call nemsio_stop endif endif iret=izero end subroutine nemsio_open !------------------------------------------------------------------------------ subroutine nemsio_close(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_close ! prgmmr: ! ! abstract: close gfile including closing the file, returning unit number, ! setting file meta data empty ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(inout) :: gfile integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: ios !------------------------------------------------------------ ! close the file !------------------------------------------------------------ if ( present(iret) ) iret=-ione call baclose(gfile%flunit,ios) if ( ios/=izero) then if ( present(iret)) then return else call nemsio_stop endif endif !------------------------------------------------------------ ! free the file unit !------------------------------------------------------------ call nemsio_clslu(gfile,ios) if ( ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif !------------------------------------------------------------ ! empty gfile meta data !------------------------------------------------------------ call nemsio_axmeta(gfile,ios) if ( ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif if ( present(iret)) iret=izero !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_close !------------------------------------------------------------------------------ subroutine nemsio_rcreate(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_rcreate ! prgmmr: ! ! abstract: read nemsio meta data ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret !local variables integer(i_kind) :: ios,nmeta integer(i_llong) :: iskip,iread,nread type(nemsio_meta1) :: meta1 type(nemsio_meta2) :: meta2 type(nemsio_meta3) :: meta3 integer(i_kind) :: i character(nemsio_charkind8),allocatable :: char8var(:) !------------------------------------------------------------ ! read first meta data record !------------------------------------------------------------ iret=-3_i_kind iskip=izero iread=nemsio_lmeta1 call bafrreadl(gfile%flunit,iskip,iread,nread,meta1) ! print *,'in rcreate, iread=',iread,'nread=',nread if(nreadizero) then iskip=iskip+nread iread=len(gfile%recname)*size(gfile%recname) call bafrreadl(gfile%flunit,iskip,iread,nread,gfile%recname) if(nreadizero) then iskip=iskip+nread iread=len(gfile%variname)*gfile%nmetavari call bafrreadl(gfile%flunit,iskip,iread,nread,gfile%variname) ! print *,'after get varint name,iskip=',iskip,'iread=',iread,'nread=',nread if(nreadizero) then ! print *,'before tlmetaryr' iskip=iskip+nwrite iwrite=len(gfile%aryrname)*gfile%nmetaaryr call bafrwritel(gfile%flunit,iskip,iwrite,nwrite,gfile%aryrname) if(nwriteizero) then do i=1,gfile%nmetaaryi if(equal_str_nocase(trim(varname),trim(gfile%aryiname(i))) ) then if(gfile%aryilen(i)==size(varval)) then gfile%aryival(1:gfile%aryilen(i),i)=varval(1:size(varval)) lhead=ione exit endif endif enddo if(lhead==ione) then iskip=gfile%tlmetaaryival nwrite=izero do i=1,gfile%nmetaaryi iskip=iskip+nwrite iwrite=kind(gfile%aryival)*gfile%aryilen(i) call bafrwritel(gfile%flunit,iskip,iwrite,nwrite, & gfile%aryival(1:gfile%aryilen(i),i)) if(nwriteizero ) then if (present(variname).and.size(variname)==gfile%nmetavari) & variname=gfile%variname if (present(varival).and.size(varival)==gfile%nmetavari) & varival=gfile%varival endif if ( gfile%nmetavarr>izero ) then if (present(varrname).and.size(varrname)==gfile%nmetavarr) & varrname=gfile%varrname if (present(varrval).and.size(varrval)==gfile%nmetavarr) & varrval=gfile%varrval endif if ( gfile%nmetavarl>izero ) then if (present(varlname).and.size(varlname)==gfile%nmetavarl) & varlname=gfile%varlname if (present(varlval).and.size(varlval)==gfile%nmetavarl) & varlval=gfile%varlval endif if ( gfile%nmetavarc>izero ) then if (present(varcname).and.size(varcname)==gfile%nmetavarc) & varcname=gfile%varcname if (present(varcval).and.size(varcval)==gfile%nmetavarc) & varcval=gfile%varcval endif if ( gfile%nmetaaryi>izero ) then if (present(aryiname).and.size(aryiname)==gfile%nmetaaryi) & aryiname=gfile%aryiname if (present(aryilen).and.size(aryilen)==gfile%nmetaaryi) & aryilen=gfile%aryilen if (present(aryival).and.size(aryival)==gfile%nmetaaryi*maxval(gfile%aryilen) ) & aryival=gfile%aryival endif if ( gfile%nmetaaryr>izero ) then if (present(aryrname).and.size(aryrname)==gfile%nmetaaryr) & aryrname=gfile%aryrname if (present(aryrlen).and.size(aryrlen)==gfile%nmetaaryr) & aryrlen=gfile%aryrlen if (present(aryrval).and.size(aryrval)==gfile%nmetaaryr*maxval(gfile%aryrlen) ) & aryrval=gfile%aryrval endif if ( gfile%nmetaaryl>izero ) then if (present(arylname).and.size(arylname)==gfile%nmetaaryl) & arylname=gfile%arylname if (present(aryllen).and.size(aryllen)==gfile%nmetaaryl) & aryllen=gfile%aryllen if (present(arylval).and.size(arylval)==gfile%nmetaaryl*maxval(gfile%aryllen) ) & arylval=gfile%arylval endif if ( gfile%nmetaaryc>izero ) then if (present(arycname).and.size(arycname)==gfile%nmetaaryc) & arycname=gfile%arycname if (present(aryclen).and.size(aryclen)==gfile%nmetaaryc) & aryclen=gfile%aryclen if (present(arycval).and.size(arycval)==gfile%nmetaaryc*maxval(gfile%aryclen) ) & arycval=gfile%arycval endif endif ! print *,'after getfilehead' if ( present(iret)) iret=izero ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_getfilehead !------------------------------------------------------------------------------ subroutine nemsio_getfheadvari(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadvari ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(len=*) ,intent(in ) :: varname integer(i_kind) ,intent( out) :: varval integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: i !--- if(present(iret) ) iret=-17_i_kind do i=1,gfile%headvarinum if(equal_str_nocase(trim(varname),trim(gfile%headvariname(i))) ) then varval=gfile%headvarival(i) if(present(iret) ) iret=izero return endif enddo !--- if(gfile%nmetavari>izero) then do i=1,gfile%nmetavari if(equal_str_nocase(trim(varname),trim(gfile%variname(i))) ) then varval=gfile%varival(i) if(present(iret) ) iret=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvari !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarr(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadvarr ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(len=*) ,intent(in ) :: varname real(r_single) ,intent( out) :: varval integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: i !--- if(present(iret) ) iret=-17_i_kind do i=1,gfile%headvarrnum if(equal_str_nocase(trim(varname),trim(gfile%headvarrname(i))) ) then varval=gfile%headvarrval(i) if(present(iret) ) iret=izero return endif enddo !--- if(gfile%nmetavarr>izero) then do i=1,gfile%nmetavarr if(equal_str_nocase(trim(varname),trim(gfile%varrname(i))) ) then varval=gfile%varrval(i) if(present(iret) ) iret=izero return endif enddo endif if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarr !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarl(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadvarl ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: varname logical(nemsio_logickind),intent( out) :: varval integer(i_kind),optional ,intent( out) :: iret integer(i_kind) :: i !--- if(present(iret) ) iret=-17_i_kind if(gfile%nmetavarl>izero) then do i=1,gfile%nmetavarl if(equal_str_nocase(trim(varname),trim(gfile%varlname(i))) ) then varval=gfile%varlval(i) if(present(iret) ) iret=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarl !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarc(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadvarc ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: varname character(*) ,intent( out) :: varval integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: i !--- if(present(iret) ) iret=-17_i_kind do i=1,gfile%headvarcnum if(equal_str_nocase(trim(varname),trim(gfile%headvarcname(i))) ) then varval=gfile%headvarcval(i) if(present(iret) ) iret=izero return endif enddo !--- if(gfile%nmetavarc>izero) then do i=1,gfile%nmetavarc if(equal_str_nocase(trim(varname),trim(gfile%varcname(i))) ) then varval=gfile%varcval(i) if(present(iret) ) iret=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarc !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryi(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadaryi ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: varname integer(i_kind) ,intent( out) :: varval(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: i,ierr !--- if(present(iret) ) iret=-17_i_kind do i=1,gfile%headaryinum if(equal_str_nocase(trim(varname),trim(gfile%headaryiname(i))) ) then varval(:)=gfile%headaryival(1:gfile%aryilen(i),i) if(present(iret) ) iret=izero return endif enddo !--- if(gfile%nmetaaryi>izero) then do i=1,gfile%nmetaaryi if(equal_str_nocase(trim(varname),trim(gfile%aryiname(i))) ) then varval(:)=gfile%aryival(1:gfile%aryilen(i),i) if(present(iret) ) iret=izero ierr=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryi !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryr(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadaryr ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: varname real(r_single) ,intent( out) :: varval(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: i,ierr !--- if(present(iret) ) iret=-17_i_kind if(gfile%headaryrnum>izero) then do i=1,gfile%headaryrnum if(equal_str_nocase(trim(varname),trim(gfile%headaryrname(i))) ) then varval(:)=gfile%headaryrval(1:gfile%aryrlen(i),i) if(present(iret) ) iret=izero return endif enddo endif !--- if(gfile%nmetaaryr>izero) then do i=1,gfile%nmetaaryr if(equal_str_nocase(trim(varname),trim(gfile%aryrname(i)))) then varval(:)=gfile%aryrval(1:gfile%aryrlen(i),i) if(present(iret) ) iret=izero ierr=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryr !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryl(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadaryl ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: varname logical(nemsio_logickind),intent( out) :: varval(:) integer(i_kind),optional ,intent( out) :: iret integer(i_kind) :: i,ierr !--- if(present(iret) ) iret=-17_i_kind if(gfile%nmetaaryl>izero) then do i=1,gfile%nmetaaryl if(equal_str_nocase(trim(varname),trim(gfile%arylname(i)))) then varval(:)=gfile%arylval(1:gfile%aryllen(i),i) if(present(iret) ) iret=izero ierr=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryl !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryc(gfile,varname,varval,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getfheadaryc ! prgmmr: ! ! abstract: get meta data var value from file header ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! varname ! ! output argument list: ! varval ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(len=*) ,intent(in ) :: varname character(*) ,intent( out) :: varval(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind) :: i,ierr !--- if(present(iret) ) iret=-17_i_kind if(gfile%headarycnum>izero) then do i=1,gfile%headarycnum if(equal_str_nocase(trim(varname),trim(gfile%headarycname(i))) ) then varval(:)=gfile%headarycval(1:gfile%aryclen(i),i) if(present(iret) ) iret=izero return endif enddo endif !--- if(gfile%nmetaaryc>izero) then do i=1,gfile%nmetaaryc if(equal_str_nocase(trim(varname),trim(gfile%arycname(i)))) then varval(:)=gfile%arycval(1:gfile%aryclen(i),i) if(present(iret) ) iret=izero ierr=izero return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryc !------------------------------------------------------------------------------ subroutine nemsio_readrec4(gfile,jrec,data,gdatatype,nframe,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_readrec4 ! prgmmr: ! ! abstract: read nemsio data by record number into a 2D 32 bits array ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! jrec ! data ! gdatatype ! nframe ! ! output argument list: ! data ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent(in ) :: jrec real(r_single) ,intent(inout) :: data(:) integer(i_kind),optional,intent( out) :: iret character(*) ,optional,intent(in ) :: gdatatype integer(i_kind),optional,intent(in ) :: nframe real(r_single),allocatable :: datatmp(:) integer(i_kind) :: i,j !------------------------------------------------------------ ! read 4 byte rec !------------------------------------------------------------ iret=-11_i_kind !--- if ( present(gdatatype) ) then if (trim(gdatatype)/=trim(gfile%gdatatype) ) then print *,'WRONG: data type not consistant in fileheader and read request' call nemsio_stop endif endif !--- allocate(datatmp(gfile%fieldsize) ) if ( gfile%gdatatype == 'bin4') then call nemsio_readrecbin4d4(gfile,jrec,datatmp,iret) if ( iret /= izero ) return else if ( gfile%gdatatype == 'bin8') then call nemsio_readrecbin8d4(gfile,jrec,datatmp,iret) if ( iret /= izero ) return else call nemsio_readrecgrb4(gfile,jrec,datatmp,iret) if ( iret /= izero ) return endif !--- if ( present(nframe) ) then if(nframe<=gfile%nframe ) then do j=1,gfile%dimy+2*gfile%nframe-2*nframe do i=1,gfile%dimx+2*gfile%nframe -2*nframe data(i+(j-ione)*(gfile%dimx+2*gfile%nframe-2*nframe))=datatmp(i+nframe & +(j-ione+nframe)*(gfile%dimx+2*gfile%nframe)) enddo enddo else print *,"WARNING: nframe is larger than the nframe in the file!" call nemsio_stop endif else data=datatmp endif deallocate(datatmp) !--- iret=izero return end subroutine nemsio_readrec4 !------------------------------------------------------------------------------ subroutine nemsio_readrec8(gfile,jrec,data,gdatatype,nframe,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_readrec8 ! prgmmr: ! ! abstract: read nemsio data (bin) by record number into a 2D 32 bits array ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! jrec ! data ! gdatatype ! nframe ! ! output argument list: ! data ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent(in ) :: jrec real(r_kind) ,intent(inout) :: data(:) integer(i_kind),optional,intent( out) :: iret character(*) ,optional,intent(in ) :: gdatatype integer(i_kind),optional,intent(in ) :: nframe real(r_kind),allocatable :: datatmp(:) integer(i_kind) :: i,j !------------------------------------------------------------ ! read 4 byte rec !------------------------------------------------------------ iret=-11_i_kind if ( present(gdatatype) ) then if (trim(gdatatype)/=trim(gfile%gdatatype) ) then print *,'WRONG: data type not consistant in fileheader and read request' call nemsio_stop endif endif allocate(datatmp(gfile%fieldsize)) if ( gfile%gdatatype == 'bin4') then call nemsio_readrecbin4d8(gfile,jrec,datatmp,iret) if ( iret /= izero ) return else if ( gfile%gdatatype == 'bin8') then call nemsio_readrecbin8d8(gfile,jrec,datatmp,iret) if ( iret /= izero ) return else call nemsio_readrecgrb8(gfile,jrec,datatmp,iret) if ( iret /= izero ) return endif !--- if ( present(nframe) ) then if(nframe<=gfile%nframe ) then do j=1,gfile%dimy+2*gfile%nframe-2*nframe do i=1,gfile%dimx+2*gfile%nframe -2*nframe data(i+(j-ione)*(gfile%dimx+2*gfile%nframe-2*nframe))=datatmp(i+nframe & +(j-ione+nframe)*(gfile%dimx+2*gfile%nframe)) enddo enddo else print *,"WARNING: nframe is larger than the nframe in the file!" call nemsio_stop endif else data=datatmp endif deallocate(datatmp) ! iret=izero return end subroutine nemsio_readrec8 !------------------------------------------------------------------------------ subroutine nemsio_readrecv4(gfile,name,levtyp,lev,data,gdatatype,nframe,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_readrecv4 ! prgmmr: ! ! abstract: read nemsio data by record number into a 2D 32 bits array ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! name ! levtyp ! lev ! data ! gdatatype ! nframe ! ! output argument list: ! data ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: name real(r_single) ,intent(inout) :: data(:) character(*) ,optional,intent(in ) :: levtyp integer(i_kind),optional,intent(in ) :: lev integer(i_kind),optional,intent( out) :: iret character(*) ,optional,intent(in ) :: gdatatype integer(i_kind),optional,intent(in ) :: nframe real(r_single),allocatable :: datatmp(:) integer(i_kind) :: i,j !------------------------------------------------------------ ! read 4 byte rec !------------------------------------------------------------ iret=-11_i_kind if ( present(gdatatype) ) then if (trim(gdatatype)/=trim(gfile%gdatatype) ) then print *,'WRONG: data type not consistant in fileheader and read request' call nemsio_stop endif endif allocate(datatmp(gfile%fieldsize) ) if ( gfile%gdatatype == 'bin4') then call nemsio_readrecvbin4(gfile,name,levtyp,lev,datatmp,iret) if ( iret /= izero ) return else if ( gfile%gdatatype == 'bin8') then call nemsio_readrecvbin8(gfile,name,levtyp,lev,datatmp,iret) if ( iret /= izero ) return else call nemsio_readrecvgrb4(gfile,name,levtyp,lev,datatmp,iret) if ( iret /= izero ) return endif !--- if ( present(nframe) ) then if(nframe<=gfile%nframe ) then do j=1,gfile%dimy+2*gfile%nframe-2*nframe do i=1,gfile%dimx+2*gfile%nframe -2*nframe data(i+(j-ione)*(gfile%dimx+2*gfile%nframe-2*nframe))=datatmp(i+nframe & +(j-ione+nframe)*(gfile%dimx+2*gfile%nframe)) enddo enddo else print *,"WARNING: nframe is larger than the nframe in the file!" call nemsio_stop endif else data=datatmp endif deallocate(datatmp) !--- iret=izero return end subroutine nemsio_readrecv4 !------------------------------------------------------------------------------ subroutine nemsio_readrecv8(gfile,name,levtyp,lev,data,gdatatype,nframe,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_readrecv8 ! prgmmr: ! ! abstract: read nemsio data by record number into a 2D 32 bits array ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! name ! levtyp ! lev ! data ! gdatatype ! nframe ! ! output argument list: ! data ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character(*) ,intent(in ) :: name real(r_kind) ,intent(inout) :: data(:) character(*) ,optional,intent(in ) :: levtyp integer(i_kind),optional,intent(in ) :: lev integer(i_kind),optional,intent( out) :: iret character(*) ,optional,intent(in ) :: gdatatype integer(i_kind),optional,intent(in ) :: nframe real(r_kind),allocatable :: datatmp(:) integer(i_kind) :: i,j !------------------------------------------------------------ ! read 8 byte rec !------------------------------------------------------------ iret=-11_i_kind if ( present(gdatatype) ) then if (trim(gdatatype)/=trim(gfile%gdatatype) ) then print *,'WRONG: data type not consistant in fileheader and read request' call nemsio_stop endif endif allocate(datatmp(gfile%fieldsize) ) if ( gfile%gdatatype == 'bin4') then call nemsio_readrecvbin4(gfile,name,levtyp,lev,datatmp,iret) if ( iret /= izero ) return else if ( gfile%gdatatype == 'bin8') then call nemsio_readrecvbin8(gfile,name,levtyp,lev,datatmp,iret) if ( iret /= izero ) return else call nemsio_readrecvgrb8(gfile,name,levtyp,lev,datatmp,iret) if ( iret /= izero ) return endif !--- if ( present(nframe) ) then if(nframe<=gfile%nframe ) then do j=1,gfile%dimy+2*gfile%nframe-2*nframe do i=1,gfile%dimx+2*gfile%nframe -2*nframe data(i+(j-ione)*(gfile%dimx+2*gfile%nframe-2*nframe))=datatmp(i+nframe & +(j-ione+nframe)*(gfile%dimx+2*gfile%nframe)) enddo enddo else print *,"WARNING: nframe is larger than the nframe in the file!" call nemsio_stop endif else data=datatmp endif deallocate(datatmp) ! iret=izero return end subroutine nemsio_readrecv8 !------------------------------------------------------------------------------ !***************** read bin data set : ******************************** !------------------------------------------------------------------------------ subroutine nemsio_readrecbin4d4(gfile,jrec,data,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_readrecbin4d4 ! prgmmr: ! ! abstract: read nemsio data (bin) by record number into a 2D 32 bits array ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! jrec ! data ! ! output argument list: ! data ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent(in ) :: jrec real(r_single) ,intent(inout) :: data(:) integer(i_kind),optional,intent( out) :: iret integer(i_llong) :: iskip,iread,nread iret=-11_i_kind iskip=gfile%tlmeta+int(jrec-ione,i_llong)*int(kind(data)*gfile%fieldsize+8_i_kind,i_llong) iread=int(r_single,i_llong)*int(size(data),i_llong) call bafrreadl(gfile%flunit,iskip,iread,nread,data) if(nread=nemsio_undef_grb)) ibms=ione ! if(present(idrt)) then call nemsio_setrqst(gfile,grbmeta,ios,jrec=jrec,w34=w34, & idrt=idrt,itr=itr,zhour=zhour,ibms=ibms) else call nemsio_setrqst(gfile,grbmeta,ios,jrec=jrec,w34=w34, & itr=itr,zhour=zhour,ibms=ibms) endif if (ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! grbmeta%lbms=.true. where(abs(data)>=nemsio_undef_grb) grbmeta%lbms=.false. mymax=minval(data) do i=1,gfile%fieldsize if(abs(data(i)) mymax) mymax=data(i) endif enddo ! !------------------------------------------------------------ ! check precision -- for pressure now !------------------------------------------------------------ if ( grbmeta%jpds(5)==ione .and. grbmeta%jpds(6)==109_i_kind ) then grbmeta%jpds(22)=min(int(5_r_single-log10(mymax)),2_i_kind) endif !------------------------------------------------------------ ! get data from putgb _w34 !------------------------------------------------------------ call putgb(gfile%flunit,grbmeta%jf,grbmeta%jpds,grbmeta%jgds, & grbmeta%lbms,data,ios) deallocate(grbmeta%lbms) if(ios/=izero) then if ( present(iret)) then print *,'putgb_ios=',ios iret=ios return else call nemsio_stop endif endif if(present(iret)) iret=izero end subroutine nemsio_writerecw34 !------------------------------------------------------------------------------ subroutine nemsio_writerecgrb4(gfile,jrec,data,iret,idrt,itr,zhour) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_writerecgrb4 ! prgmmr: ! ! abstract: read nemsio data by record number into a 2D 32bits array, ! using w3_d library to compile ! program history log: ! 2009-08-31 lueken -added subprogram doc block ! ! input argument list: ! gfile ! jrec ! data ! idrt ! itr ! zhour ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent(in ) :: jrec real(r_single) ,intent(in ) :: data(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind),optional,intent(in ) :: idrt integer(i_kind),optional,intent(in ) :: itr real(r_single) ,optional,intent(in ) :: zhour real(r_kind),allocatable :: data8(:) type(nemsio_grbmeta) :: grbmeta integer(i_kind) :: nc,i,nc1 integer(i_kind) :: ios,ibms real(r_single) :: mymax !------------------------------------------------------------ ! set up grib meta !------------------------------------------------------------ if(present(iret)) iret=-4_i_kind !------------------------------------------------------------ ! set up grib meta ibms !------------------------------------------------------------ ibms=izero ! allocate(data8(size(data)) ) data8=data if(any(abs(data8)>=nemsio_undef_grb)) ibms=izero ! !------------------------------------------------------------ ! set up grib meta data !------------------------------------------------------------ if(present(idrt)) then call nemsio_setrqst(gfile,grbmeta,ios,jrec=jrec,idrt=idrt, & itr=itr,zhour=zhour,ibms=ibms) else call nemsio_setrqst(gfile,grbmeta,ios,jrec=jrec, & itr=itr,zhour=zhour,ibms=ibms) endif if (ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! !------------------------------------------------------------ ! set up lbms !------------------------------------------------------------ grbmeta%lbms=.true. where(abs(data8)>=nemsio_undef_grb) grbmeta%lbms=.false. mymax=minval(data8) do i=1,gfile%fieldsize if(abs(data8(i)) mymax) mymax=data8(i) endif enddo ! write(0,*)'in writerecgrb4,max=',mymax,'nc=',nc,'nc1=',nc1,'imb=',ibms, & ! 'size(data)=',size(data),'size(lbms)=',size(grbmeta%lbms), & ! grbmeta%lbms(1:15),data8(1:15) ! !------------------------------------------------------------ ! check precision -- for pressure now !------------------------------------------------------------ if ( grbmeta%jpds(5)==ione .and. grbmeta%jpds(6)==109_i_kind ) then grbmeta%jpds(22)=min(int(5_r_single-log10(mymax)),2_i_kind) endif !------------------------------------------------------------ ! get data from putgb _w3d !------------------------------------------------------------ ! allocate(data8(size(data)) ) ! data8=data ! write(0,*)'in writerecgrb4,before putgb=',grbmeta%lbms(1:15) call putgb(gfile%flunit,grbmeta%jf,grbmeta%jpds,grbmeta%jgds, & grbmeta%lbms,data8,ios) deallocate(grbmeta%lbms) if(ios/=izero) then if ( present(iret)) then print *,'putgb_ios=',ios iret=ios return else call nemsio_stop endif endif if(present(iret)) iret=izero end subroutine nemsio_writerecgrb4 !------------------------------------------------------------------------------ subroutine nemsio_writerecgrb8(gfile,jrec,data8,iret,idrt,itr,zhour) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_writerecgrb8 ! prgmmr: ! ! abstract: read nemsio data by record number into a 2D 64bits array, ! using w3_d library to compile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! jrec ! data8 ! idrt ! itr ! zhour ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent(in ) :: jrec real(r_kind) ,intent(in ) :: data8(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind),optional,intent(in ) :: idrt integer(i_kind),optional,intent(in ) :: itr real(r_single) ,optional,intent(in ) :: zhour type(nemsio_grbmeta) :: grbmeta integer(i_kind) :: i integer(i_kind) :: ios,ibms !--- real(r_single) :: mymax !------------------------------------------------------------ ! set up grib meta !------------------------------------------------------------ if(present(iret)) iret=-4_i_kind !------------------------------------------------------------ ! set up grib meta lbms !------------------------------------------------------------ ibms=izero if(any(abs(data8)>=nemsio_undef_grb)) ibms=ione ! if(present(idrt)) then call nemsio_setrqst(gfile,grbmeta,ios,jrec=jrec,idrt=idrt, & itr=itr,zhour=zhour,ibms=ibms) else call nemsio_setrqst(gfile,grbmeta,ios,jrec=jrec, & itr=itr,zhour=zhour,ibms=ibms) endif if (ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! grbmeta%lbms=.true. where(abs(data8)>=nemsio_undef_grb) grbmeta%lbms=.false. mymax=minval(data8) do i=1,gfile%fieldsize if(abs(data8(i)) mymax) mymax=data8(i) endif enddo ! !------------------------------------------------------------ ! check precision -- for pressure now !------------------------------------------------------------ if ( grbmeta%jpds(5)==ione .and. grbmeta%jpds(6)==109_i_kind ) then grbmeta%jpds(22)=min(int(5_r_single-log10(mymax)),2_i_kind) endif !------------------------------------------------------------ ! get data from putgb _w3d !------------------------------------------------------------ call putgb(gfile%flunit,grbmeta%jf,grbmeta%jpds,grbmeta%jgds, & grbmeta%lbms,data8,ios) deallocate(grbmeta%lbms) if(ios/=izero) then if ( present(iret)) then print *,'putgb_ios=',ios iret=ios return else call nemsio_stop endif endif if(present(iret)) iret=izero end subroutine nemsio_writerecgrb8 !------------------------------------------------------------------------------ subroutine nemsio_writerecvw34(gfile,vname,vlevtyp,vlev,data,iret,idrt, & itr,zhour) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_writerecvw34 ! prgmmr: ! ! abstract: read nemsio data by field name into a 2D 32bits array, ! using w3_4 library to compile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! vname,vlevtyp ! vlev ! data ! idrt ! itr ! zhour ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character*(*) ,intent(in ) :: vname,vlevtyp integer(i_kind) ,intent(in ) :: vlev real(r_single) ,intent(in ) :: data(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind),optional,intent(in ) :: idrt integer(i_kind),optional,intent(in ) :: itr real(r_single) ,optional,intent(in ) :: zhour type(nemsio_grbmeta) :: grbmeta integer(i_kind) :: i integer(i_kind) :: ios,w34,ibms real(r_single) :: mymax !------------------------------------------------------------ ! set up grib meta !------------------------------------------------------------ if(present(iret)) iret=-4_i_kind !------------------------------------------------------------ ! set up grib meta lbms !------------------------------------------------------------ ibms=izero if(any(abs(data)>=nemsio_undef_grb)) ibms=ione ! w34=ione if(present(idrt)) then call nemsio_setrqst(gfile,grbmeta,ios,vname=vname, & vlevtyp=vlevtyp, vlev=vlev, w34=w34, idrt=idrt, & itr=itr,zhour=zhour,ibms=ibms) else call nemsio_setrqst(gfile,grbmeta,ios,vname=vname, & vlevtyp=vlevtyp, vlev=vlev, w34=w34,itr=itr, & zhour=zhour,ibms=ibms) endif if (ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! grbmeta%lbms=.true. where(abs(data)>=nemsio_undef_grb) grbmeta%lbms=.false. mymax=minval(data) do i=1,gfile%fieldsize if(abs(data(i)) mymax) mymax=data(i) endif enddo ! !------------------------------------------------------------ ! check precision -- for pressure now !------------------------------------------------------------ if ( grbmeta%jpds(5)==ione .and. grbmeta%jpds(6)==109_i_kind ) then grbmeta%jpds(22)=min(int(5_r_single-log10(mymax)),2_i_kind) endif !------------------------------------------------------------ ! get data from putgb _w34 !------------------------------------------------------------ call putgb(gfile%flunit,grbmeta%jf,grbmeta%jpds,grbmeta%jgds, & grbmeta%lbms,data,ios) deallocate(grbmeta%lbms) if(ios/=izero) then if ( present(iret)) then print *,'putgb_ios=',ios iret=ios return else call nemsio_stop endif endif if(present(iret)) iret=izero end subroutine nemsio_writerecvw34 !------------------------------------------------------------------------------ subroutine nemsio_writerecvgrb4(gfile,vname,vlevtyp,vlev,data,iret,idrt, & itr,zhour) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_writerecvgrb4 ! prgmmr: ! ! abstract: read nemsio data by field name into a 2D 32bits array, ! using w3_d library to compile ! ! program history log: ! 2009-08-31 lueken - added documentation block ! ! input argument list: ! gfile ! vname,vlevtyp ! vlev ! data ! idrt ! itr ! zhour ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character*(*) ,intent(in ) :: vname,vlevtyp integer(i_kind) ,intent(in ) :: vlev real(r_single) ,intent(in ) :: data(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind),optional,intent(in ) :: idrt integer(i_kind),optional,intent(in ) :: itr real(r_single) ,optional,intent(in ) :: zhour real(r_kind),allocatable :: data8(:) type(nemsio_grbmeta) :: grbmeta integer(i_kind) :: i integer(i_kind) :: ios,ibms real(r_single) :: mymax !------------------------------------------------------------ ! set up grib meta !------------------------------------------------------------ if(present(iret)) iret=-4_i_kind !------------------------------------------------------------ ! set up grib meta lbms !------------------------------------------------------------ ibms=izero if(any(abs(data)>=nemsio_undef_grb)) ibms=ione ! if(present(idrt)) then call nemsio_setrqst(gfile,grbmeta,ios,vname=vname, & vlevtyp=vlevtyp, vlev=vlev, idrt=idrt,itr=itr, & zhour=zhour,ibms=ibms) else call nemsio_setrqst(gfile,grbmeta,ios,vname=vname, & vlevtyp=vlevtyp, vlev=vlev,itr=itr,zhour=zhour,ibms=ibms) endif if (ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! grbmeta%lbms=.true. where(abs(data)>=nemsio_undef_grb) grbmeta%lbms=.false. mymax=minval(data) do i=1,gfile%fieldsize if(abs(data(i)) mymax) mymax=data(i) endif enddo ! !------------------------------------------------------------ ! check precision -- for pressure now !------------------------------------------------------------ if ( grbmeta%jpds(5)==ione .and. grbmeta%jpds(6)==109_i_kind ) then grbmeta%jpds(22)=min(int(5_r_single-log10(mymax)),2_i_kind) endif !------------------------------------------------------------ ! get data from putgb _w3d !------------------------------------------------------------ allocate(data8(size(data)) ) daTa8=data call putgb(gfile%flunit,grbmeta%jf,grbmeta%jpds,grbmeta%jgds, & grbmeta%lbms,data8,ios) deallocate(grbmeta%lbms) if(ios/=izero) then if ( present(iret)) then print *,'putgb_ios=',ios iret=ios return else call nemsio_stop endif endif if(present(iret)) iret=izero end subroutine nemsio_writerecvgrb4 !------------------------------------------------------------------------------ subroutine nemsio_writerecvgrb8(gfile,vname,vlevtyp,vlev,data8,iret,idrt,itr, & zhour) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_writerecvgrb8 ! prgmmr: ! ! abstract: read nemsio data by field name into a 2D 64bits array, ! using w3_d library to compile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! vname,vlevtyp ! vlev ! data8 ! idrt ! itr ! zhour ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile character*(*) ,intent(in ) :: vname,vlevtyp integer(i_kind) ,intent(in ) :: vlev real(r_kind) ,intent(in ) :: data8(:) integer(i_kind),optional,intent( out) :: iret integer(i_kind),optional,intent(in ) :: idrt integer(i_kind),optional,intent(in ) :: itr real(r_single) ,optional,intent(in ) :: zhour type(nemsio_grbmeta) :: grbmeta integer(i_kind) :: i integer(i_kind) :: ios,ibms real(r_single) :: mymax !------------------------------------------------------------ ! set up grib meta !------------------------------------------------------------ if(present(iret)) iret=-4_i_kind !------------------------------------------------------------ ! set up grib meta lbms !------------------------------------------------------------ ibms=izero if(any(abs(data8)>=nemsio_undef_grb)) ibms=ione ! if(present(idrt)) then call nemsio_setrqst(gfile,grbmeta,ios,vname=vname, & vlevtyp=vlevtyp, vlev=vlev, idrt=idrt,itr=itr, & zhour=zhour,ibms=ibms) else call nemsio_setrqst(gfile,grbmeta,ios,vname=vname, & vlevtyp=vlevtyp, vlev=vlev,itr=itr,zhour=zhour,ibms=ibms) endif if (ios/=izero) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif ! grbmeta%lbms=.true. where(abs(data8)>=nemsio_undef_grb) grbmeta%lbms=.false. mymax=minval(data8) do i=1,gfile%fieldsize if(abs(data8(i)) mymax) mymax=data8(i) endif enddo ! !------------------------------------------------------------ ! check precision -- for pressure now !------------------------------------------------------------ if ( grbmeta%jpds(5)==ione .and. grbmeta%jpds(6)==109_i_kind ) then grbmeta%jpds(22)=min(int(5_r_single-log10(mymax)),2_i_kind) endif !------------------------------------------------------------ ! get data from putgb _w3d !------------------------------------------------------------ call putgb(gfile%flunit,grbmeta%jf,grbmeta%jpds,grbmeta%jgds, & grbmeta%lbms,data8,ios) deallocate(grbmeta%lbms) if(ios/=izero) then if ( present(iret)) then print *,'putgb_ios=',ios iret=ios return else call nemsio_stop endif endif if(present(iret)) iret=izero end subroutine nemsio_writerecvgrb8 !---------------------------------------------------------------------------- subroutine nemsio_setrqst(gfile,grbmeta,iret,jrec,vname,vlevtyp,vlev,w34,idrt, & itr,zhour,ibms) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_setrqst ! prgmmr: ! ! abstract: if given record number, find record name, lev typ, and levs or ! record name,lev type and lev can be got from argument list. ! with record name,lev typ and level, set up grib meta, jpds and ! jgds ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! jrec ! vname,vlevtyp ! vlev ! w34 ! idrt ! itr ! zhour ! ibms ! ! output argument list: ! grbmeta ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile type(nemsio_grbmeta) ,intent( out) :: grbmeta integer(i_kind) ,intent( out) :: iret integer(i_kind),optional,intent(in ) :: jrec character(*) ,optional,intent(in ) :: vname,vlevtyp integer(i_kind),optional,intent(in ) :: vlev integer(i_kind),optional,intent(in ) :: w34 integer(i_kind),optional,intent(in ) :: idrt integer(i_kind),optional,intent(in ) :: itr real(r_single) ,optional,intent(in ) :: zhour integer(i_kind),optional,intent(in ) :: ibms character(255) :: name,levtyp integer(i_kind) :: icen,igrid,iptv,jbms,jftu,jp1,jp2,jtr,jna,jnm,ios integer(i_kind) :: lev,ktbl,krec,idrt_in !------------------------------------------------------------ ! with record number, find record name, level type and level !------------------------------------------------------------ iret=-5_i_kind if ( present(jrec)) then if ( jrec>izero .and. jrec<=gfile%nrec) then name=gfile%recname(jrec) levtyp=gfile%reclevtyp(jrec) lev=gfile%reclev(jrec) else return endif elseif ( present(vname) .and. present(vlevtyp) .and. present(vlev)) then name=trim(vname) levtyp=trim(vlevtyp) lev=vlev else return endif !------------------------------------------------------------ ! find index in grib table according to recname and reclevtyp !------------------------------------------------------------ call nemsio_grbtbl_search(trim(name),trim(levtyp),ktbl,krec,ios) if(ios/=izero) return !*** lev: for special layer ! if ( gribtable(ktbl)%item(krec)%leveltype =='sfc' ) then if ( trim(gribtable(ktbl)%item(krec)%leveltype) /= 'layer' .and. & trim(gribtable(ktbl)%item(krec)%leveltype) /= 'mid layer' ) then lev=izero endif ! print *,'in searchrst,jrec=',jrec,'name=',trim(name),'levtyp=',trim(levtyp),& ! 'lev=',lev,'gribtb levtype=',gribtable(ktbl)%item(krec)%leveltype !------------------------------------------------------------ ! for read, just need to set up jpds(05-07) !------------------------------------------------------------ !--- read:set jpds5,6,7 ! if ( lowercase(gfile%gaction)(1:4)=="read") then if ( equal_str_nocase(trim(gfile%gaction),"read") ) then grbmeta%jpds(05)=gribtable(ktbl)%item(krec)%g1param grbmeta%jpds(06)=gribtable(ktbl)%item(krec)%g1level grbmeta%jpds(07)=lev if ( grbmeta%jpds(06)==110_i_kind ) then grbmeta%jpds(07)=256*(lev-ione)+lev endif if (gribtable(ktbl)%item(krec)%g1lev/=izero) then grbmeta%jpds(07)=gribtable(ktbl)%item(krec)%g1lev endif else !------------------------------------------------------------ ! for write, need to set up jgds(1:25), jpds(01-20) !------------------------------------------------------------ if (present(idrt)) then idrt_in = idrt else !*** gfile idrt idrt_in=gfile%idrt endif !*** for itr jftu=ione jtr=10_i_kind jp1=gfile%nfhour jp2=izero if(present(itr) ) then jtr=itr if(itr==3_i_kind.or.itr==2_i_kind.or.itr==4_i_kind) then !avg if(present(zhour)) then jp1=nint(zhour) jp2=gfile%nfhour else print *,'ERROR in nemsio gribfile,itr=',itr,'need to set zhour' endif endif endif jbms=izero if(present(ibms)) jbms=ibms ! icen=7_i_kind ! if ( present(w34) ) then call nemsio_makglgds(gfile,idrt_in,igrid,grbmeta%jgds,ios,w34) else call nemsio_makglgds(gfile,idrt_in,igrid,grbmeta%jgds,ios) ! write(0,*)'after nemsio_makglgds,idrt=',idrt_in,'ios=',ios,'igrid=',igrid, & ! 'jbms=',jbms endif if(ios/=izero) return iptv=gribtable(ktbl)%iptv jna=izero jnm=izero call nemsio_makglpds(gfile,iptv,icen,igrid,jbms,& jftu,jp1,jp2,jtr,jna,jnm,ktbl,krec,lev,grbmeta%jpds,ios) ! write(0,*)'after nemsio_makglpds,jpds=',grbmeta%jpds(1:25),'ios=',ios, & ! 'lev=',lev if(ios/=izero) return endif !------------------------------------------------------------ ! set up grib meta lbms !------------------------------------------------------------ grbmeta%jf=gfile%fieldsize allocate(grbmeta%lbms(grbmeta%jf)) iret=izero end subroutine nemsio_setrqst !------------------------------------------------------------------------------ subroutine nemsio_getrechead(gfile,jrec,name,levtyp,lev,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getrechead ! prgmmr: ! ! abstract: given record number, return users record name, lev typ, and levs ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! jrec ! name ! levtyp ! ! output argument list: ! name ! levtyp ! lev ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent(in ) :: jrec character(*) ,intent(inout) :: name character(*) ,optional,intent(inout) :: levtyp integer(i_kind),optional,intent( out) :: lev integer(i_kind),optional,intent( out) :: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if( present(iret)) iret=-5_i_kind if ( jrec>izero .or. jrec<=gfile%nrec) then if(gfile%nmeta>2_i_kind) then name=gfile%recname(jrec) else print *,'WRONG: recname is not specified in meta data!' return endif if(present(levtyp).and.gfile%nmeta>3_i_kind) then levtyp=gfile%reclevtyp(jrec) endif if(present(lev).and.gfile%nmeta>4_i_kind) then lev=gfile%reclev(jrec) endif if(present(iret)) iret=izero ! print *,'in getrechead, nrec=',gfile%nrec,'name=',name,'levtyp=',levtyp,'lev=',lev return else if ( present(iret)) then print *,'WRONG: jrec is either less than 1 or greater than gfile%nrec' return else call nemsio_stop endif endif end subroutine nemsio_getrechead !------------------------------------------------------------------------------ subroutine nemsio_makglgds(gfile,idrt,igrid,kgds,iret,w34) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_makglgds ! prgmmr: ! ! abstract: set up gds for grib meta ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! idrt ! w34 ! ! output argument list: ! iret ! igrid,kgds ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(in ) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) ,intent(in ) :: idrt integer(i_kind) ,intent( out) :: igrid,kgds(200) integer(i_kind),optional,intent(in ) :: w34 real(r_kind) :: slat8(gfile%dimy) real(r_single) :: slat4(gfile%dimy) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-5_i_kind igrid=255_i_kind if(idrt==izero .and.gfile%dimx==144_i_kind.and.gfile%dimy== 73_i_kind) igrid=2_i_kind if(idrt==izero .and.gfile%dimx==360_i_kind.and.gfile%dimy==181_i_kind) igrid=3_i_kind if(idrt==izero .and.gfile%dimx==720_i_kind.and.gfile%dimy==361_i_kind) igrid=4_i_kind if(idrt==4_i_kind.and.gfile%dimx==192_i_kind.and.gfile%dimy== 94_i_kind) igrid=98_i_kind if(idrt==4_i_kind.and.gfile%dimx==384_i_kind.and.gfile%dimy==192_i_kind) igrid=126_i_kind if(idrt==4_i_kind.and.gfile%dimx==512_i_kind.and.gfile%dimy==256_i_kind) igrid=170_i_kind if(idrt==4_i_kind.and.gfile%dimx==768_i_kind.and.gfile%dimy==384_i_kind) igrid=127_i_kind ! write(0,*)'in nemsio_makdglgds,idrt=',idrt,'dimx=',gfile%dimx,'dimy=',gfile%dimy kgds(1)=modulo(idrt,256) kgds(2)=gfile%dimx kgds(3)=gfile%dimy select case(idrt) case(0) kgds(4)=90000_i_kind case(4) !------------------------------------------------------------ ! call different split for w3_4 lib and w3_d lib !------------------------------------------------------------ if (present (w34)) then call splat(idrt,gfile%dimy,slat4) kgds(4)=nint(180000._r_kind/acos(-one)*asin(slat4(ione))) else call splat(idrt,gfile%dimy,slat8) kgds(4)=nint(180000._r_kind/acos(-one)*asin(slat8(ione))) endif case(256) kgds(4)=90000_i_kind-nint(half*180000._r_kind/gfile%dimy) end select kgds(5)=izero kgds(6)=128_i_kind kgds(7)=-kgds(4) kgds(8)=-nint(360000._r_kind/gfile%dimx) kgds(9)=-kgds(8) select case(idrt) case(0) kgds(10)=nint(180000._r_kind/(gfile%dimy-ione)) case(4) kgds(10)=gfile%dimy/2 case(256) kgds(10)=nint(180000._r_kind/gfile%dimy) end select kgds(11)=izero kgds(12)=izero kgds(13:18)=-ione kgds(19)=izero kgds(20)=255 kgds(21:)=-ione iret=izero end subroutine nemsio_makglgds !------------------------------------------------------------------------------ subroutine nemsio_makglpds(gfile,iptv,icen,igrid,ibms,& iftu,ip1,ip2,itr,ina,inm,ktbl,krec,lev,kpds,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_makglpds ! prgmmr: ! ! abstract: set up gps for grib meta ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! iptv,icen,igrid,ibms ! iftu,ip1,ip2,itr,ina,inm,ktbl,krec,lev ! ! output argument list: ! kpds ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(in ) :: gfile integer(i_kind) ,intent(in ) :: iptv,icen,igrid,ibms integer(i_kind) ,intent(in ) :: iftu,ip1,ip2,itr,ina,inm,ktbl,krec,lev integer(i_kind) ,intent( out) :: kpds(200) integer(i_kind) ,intent( out) :: iret integer(i_kind) :: igen,icen2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-5_i_kind ! !get igen icen2 call nemsio_getheadvar(gfile,'igen',igen,iret) if (iret/=izero ) then if(trim(gfile%modelname)=='GFS') igen=82_i_kind else print *,'ERROR: please specify model generating flag' return endif call nemsio_getheadvar(gfile,'icen2',icen2,iret) if (iret/=izero ) then if(trim(gfile%modelname)=='GFS') then icen2=izero else print *,'ERROR: please specify subcenter id,modelname=',gfile%modelname return endif endif ! kpds(01)=icen kpds(02)=igen kpds(03)=igrid kpds(04)=128_i_kind+64*ibms kpds(05)=gribtable(ktbl)%item(krec)%g1param kpds(06)=gribtable(ktbl)%item(krec)%g1level kpds(07)=lev if(gribtable(ktbl)%item(krec)%g1lev/=izero)then kpds(07)=gribtable(ktbl)%item(krec)%g1lev endif !*** deal with dpres if ( kpds(06)==110_i_kind ) then kpds(07)=256*(lev-ione)+lev endif !*** kpds(08)=mod(gfile%idate(1)-ione,100_i_kind)+ione kpds(09)=gfile%idate(2) kpds(10)=gfile%idate(3) kpds(11)=gfile%idate(4) kpds(12)=izero kpds(13)=iftu kpds(14)=ip1 kpds(15)=ip2 kpds(16)=itr kpds(17)=ina kpds(18)=ione kpds(19)=iptv kpds(20)=inm kpds(21)=(gfile%idate(1)-ione)/100+ione kpds(22)=gribtable(ktbl)%item(krec)%precision kpds(23)=icen2 kpds(24)=izero kpds(25)=izero kpds(26:)=-ione iret=izero ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_makglpds !------------------------------------------------------------------------------ subroutine nemsio_grbtbl_search(vname,vlevtyp,ktbl,krec,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_grbtbl_search ! prgmmr: ! ! abstract: given record name, levtyp and index number in grib table ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! vname,vlevtyp ! ! output argument list: ! ktbl,krec ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none character(*) ,intent(in ) :: vname,vlevtyp integer(i_kind),intent( out) :: ktbl,krec integer(i_kind),intent( out) :: iret integer(i_kind) :: i,j,nlen,nlen1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-5_i_kind nlen=len(trim(vname)) nlen1=len(trim(vlevtyp)) ktbl=izero krec=izero ! write(0,*)'vname=',vname,'vlevtyp=',vlevtyp,'nlen=',nlen,'nlen1=',nlen1 do j=1,size(gribtable) do i=1,size(gribtable(j)%item) if(equal_str_nocase(trim(vname),trim(gribtable(j)%item(i)%shortname)) .and. & equal_str_nocase(trim(vlevtyp),trim(gribtable(j)%item(i)%leveltype)) )then ktbl=j krec=i iret=izero exit endif enddo enddo ! write(0,*)'in grbtbl_search,krec=',krec,'ktbl=',ktbl end subroutine nemsio_grbtbl_search !------------------------------------------------------------------------------ subroutine nemsio_chkgfary(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_chkgfary ! pgrmmr: ! ! abstract: check if arrays in gfile is allocated and with right size ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2_i_kind if ( gfile%dimx == nemsio_intfill .or. gfile%dimy == nemsio_intfill & .or. gfile%dimz == nemsio_intfill .or. gfile%nrec == nemsio_intfill ) then print *,'WRONG: dimx,dimy,dimz and nrec must be defined!' return endif if(gfile%nmeta>5_i_kind) then if (.not. allocated(gfile%vcoord) .or. size(gfile%vcoord)/= & (gfile%dimz+ione)*3*2 ) then call nemsio_almeta1(gfile,ios) if (ios /= izero) return endif endif if(gfile%nmeta>6_i_kind) then if (.not.allocated(gfile%lat) .or. size(gfile%lat)/=gfile%fieldsize .or.& .not.allocated(gfile%lon) .or. size(gfile%lon)/=gfile%fieldsize .or.& .not.allocated(gfile%dx) .or. size(gfile%dx) /=gfile%fieldsize .or.& .not.allocated(gfile%dy) .or. size(gfile%dy) /=gfile%fieldsize) then call nemsio_almeta2(gfile,ios) if (ios /= izero) return endif endif if(gfile%nmeta>10_i_kind) then if(gfile%ntrac==nemsio_intfill) then print *,'WRONG: ntrac is not defined!' return endif if (.not.allocated(gfile%Cpi) .or. size(gfile%Cpi)/=gfile%ntrac+ione .or. & .not.allocated(gfile%Ri) .or. size(gfile%Ri)/=gfile%ntrac+ione ) then call nemsio_almeta3(gfile,ios) if (ios /= izero) return endif endif if(gfile%nmeta>2_i_kind) then if (allocated(gfile%recname) .and. size(gfile%recname)==gfile%nrec)& then if (allocated(gfile%reclevtyp) .and. size(gfile%reclevtyp) & ==gfile%nrec) then if (allocated(gfile%reclev) .and. size(gfile%reclev)== & gfile%nrec) then iret=izero return endif endif endif call nemsio_almeta4(gfile,ios) if (ios /= izero) return endif iret=izero end subroutine nemsio_chkgfary !------------------------------------------------------------------------------ subroutine nemsio_almeta(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_almeta ! prgmmr: ! ! abstract: allocate all the arrays in gfile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: dimvcoord1 integer(i_kind) :: dimrecname,dimreclevtyp,dimreclev integer(i_kind) :: dimfield integer(i_kind) :: dimcpr integer(i_kind) :: iret1,iret2,iret3,iret4 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=izero dimvcoord1=gfile%dimz+ione dimrecname=gfile%nrec dimreclevtyp=gfile%nrec dimreclev=gfile%nrec dimfield=gfile%fieldsize dimcpr=gfile%ntrac+ione if(allocated(gfile%recname)) deallocate(gfile%recname) if(allocated(gfile%reclevtyp)) deallocate(gfile%reclevtyp) if(allocated(gfile%reclev)) deallocate(gfile%reclev) if(allocated(gfile%vcoord)) deallocate(gfile%vcoord) if(allocated(gfile%lat)) deallocate(gfile%lat) if(allocated(gfile%lon)) deallocate(gfile%lon) if(allocated(gfile%dx)) deallocate(gfile%dx) if(allocated(gfile%dy)) deallocate(gfile%dy) if(allocated(gfile%Cpi)) deallocate(gfile%Cpi) if(allocated(gfile%Ri)) deallocate(gfile%Ri) if(gfile%nmeta>2_i_kind)then allocate(gfile%recname(dimrecname), gfile%reclevtyp(dimreclevtyp), & gfile%reclev(dimreclev), & stat=iret1) if(iret1==izero) then gfile%reclev=nemsio_intfill gfile%recname=' ' gfile%reclevtyp=' ' endif iret=iret+abs(iret1) endif if(gfile%nmeta>5_i_kind)then allocate(gfile%vcoord(dimvcoord1,3,2) ,stat=iret2) if(iret3==izero) then gfile%vcoord=nemsio_realfill endif iret=iret+abs(iret2) endif if(gfile%nmeta>6_i_kind)then allocate(gfile%lat(dimfield), gfile%lon(dimfield), & gfile%dx(dimfield), gfile%dy(dimfield) ,stat=iret3) if(iret3==izero) then gfile%lat=nemsio_realfill gfile%lon=nemsio_realfill gfile%dx=nemsio_realfill gfile%dy=nemsio_realfill endif iret=iret+abs(iret3) endif if(gfile%nmeta>10_i_kind)then allocate(gfile%Cpi(dimcpr), gfile%Ri(dimcpr), stat=iret4) if(iret4==izero) then gfile%Cpi=nemsio_realfill gfile%Ri=nemsio_realfill endif iret=iret+abs(iret4) endif ! print *,'iret1=',iret1,'iret2=',iret2,'dimx=',gfile%dimx,'dimy=',gfile%dimy,'nframe=',gfile%nframe if(iret/=izero) iret=-6_i_kind end subroutine nemsio_almeta !------------------------------------------------------------------------------ subroutine nemsio_alextrameta(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_alextrameta ! prgmmr: ! ! abstract: allocate all the arrays in gfile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: iret1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-6_i_kind if(gfile%extrameta) then ! print *,'nmetavari=',gfile%nmetavari,'nmetavarr=',gfile%nmetavarr, & ! 'nmetavarl=',gfile%nmetavarl,'nmetavarc=',gfile%nmetavarc, & ! 'nmetaaryi=',gfile%nmetaaryi,'nmetaaryr=',gfile%nmetaaryi, & ! 'nmetaaryl=',gfile%nmetaaryl,'nmetaaryc=',gfile%nmetaaryc if(gfile%nmetavari>izero) then if(allocated(gfile%variname)) deallocate(gfile%variname) if(allocated(gfile%varival)) deallocate(gfile%varival) allocate(gfile%variname(gfile%nmetavari), & gfile%varival(gfile%nmetavari), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetavarr>izero) then if(allocated(gfile%varrname)) deallocate(gfile%varrname) if(allocated(gfile%varrval)) deallocate(gfile%varrval) allocate(gfile%varrname(gfile%nmetavarr), & gfile%varrval(gfile%nmetavarr), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetavarl>izero) then if(allocated(gfile%varlname)) deallocate(gfile%varlname) if(allocated(gfile%varlval)) deallocate(gfile%varlval) allocate(gfile%varlname(gfile%nmetavarl), & gfile%varlval(gfile%nmetavarl), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetavarc>izero) then if(allocated(gfile%varcname)) deallocate(gfile%varcname) if(allocated(gfile%varcval)) deallocate(gfile%varcval) allocate(gfile%varcname(gfile%nmetavarc), & gfile%varcval(gfile%nmetavarc), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetaaryi>izero) then if(allocated(gfile%aryiname)) deallocate(gfile%aryiname) if(allocated(gfile%aryilen)) deallocate(gfile%aryilen) if(allocated(gfile%aryival)) deallocate(gfile%aryival) allocate(gfile%aryiname(gfile%nmetaaryi), & gfile%aryilen(gfile%nmetaaryi), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetaaryr>izero) then if(allocated(gfile%aryrname)) deallocate(gfile%aryrname) if(allocated(gfile%aryrlen)) deallocate(gfile%aryrlen) if(allocated(gfile%aryrval)) deallocate(gfile%aryrval) allocate(gfile%aryrname(gfile%nmetaaryr), & gfile%aryrlen(gfile%nmetaaryr), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetaaryl>izero) then if(allocated(gfile%arylname)) deallocate(gfile%arylname) if(allocated(gfile%aryllen)) deallocate(gfile%aryllen) if(allocated(gfile%arylval)) deallocate(gfile%arylval) allocate(gfile%arylname(gfile%nmetaaryl), & gfile%aryllen(gfile%nmetaaryl), stat=iret1 ) if(iret1/=izero) return endif if(gfile%nmetaaryc>izero) then if(allocated(gfile%arycname)) deallocate(gfile%arycname) if(allocated(gfile%aryclen)) deallocate(gfile%aryclen) if(allocated(gfile%arycval)) deallocate(gfile%arycval) allocate(gfile%arycname(gfile%nmetaaryc), & gfile%aryclen(gfile%nmetaaryc), stat=iret1 ) if(iret1/=izero) return endif endif iret=izero ! print *,'end of alextrameta' end subroutine nemsio_alextrameta !------------------------------------------------------------------------------ subroutine nemsio_almeta1(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_almeta1 ! prgmmr: ! ! abstract: allocate vcoord in gfile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: dimvcoord1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dimvcoord1=gfile%dimz+ione if(allocated(gfile%vcoord)) deallocate(gfile%vcoord) allocate(gfile%vcoord(dimvcoord1,3,2), stat=iret) if(iret==izero) then gfile%vcoord=nemsio_realfill endif if(iret/=izero) iret=-6_i_kind end subroutine nemsio_almeta1 !------------------------------------------------------------------------------ subroutine nemsio_almeta2(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_almeta2 ! prgmmr: ! ! abstract: allocate lat1d in gfile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: dimlat ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dimlat=gfile%fieldsize if(allocated(gfile%lat)) deallocate(gfile%lat) if(allocated(gfile%lon)) deallocate(gfile%lon) if(allocated(gfile%dx)) deallocate(gfile%dx) if(allocated(gfile%dy)) deallocate(gfile%dy) allocate(gfile%lat(dimlat),gfile%lon(dimlat), & gfile%dx(dimlat),gfile%dy(dimlat), stat=iret) if(iret==izero) then gfile%lat=nemsio_realfill gfile%lon=nemsio_realfill gfile%dx=nemsio_realfill gfile%dy=nemsio_realfill endif if(iret/=izero) iret=-6_i_kind end subroutine nemsio_almeta2 !------------------------------------------------------------------------------ subroutine nemsio_almeta3(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_almeta3 ! prgmmr: ! ! abstract: allocate lon1d in gfile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: dim1d ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1d=gfile%ntrac+ione if(allocated(gfile%Cpi)) deallocate(gfile%Cpi) if(allocated(gfile%Ri)) deallocate(gfile%Ri) allocate(gfile%Cpi(dim1d),gfile%Ri(dim1d),stat=iret) if(iret==izero) then gfile%Cpi=nemsio_realfill gfile%Ri=nemsio_realfill endif if(iret/=izero) iret=-6_i_kind end subroutine nemsio_almeta3 !------------------------------------------------------------------------------ subroutine nemsio_almeta4(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_almeta4 ! prgmmr: ! ! abstract: allocate recnam, reclvevtyp, and reclev in gfile ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: dimrecname,dimreclevtyp,dimreclev ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(gfile%nrec2_i_kind) then if(allocated(gfile%recname)) deallocate(gfile%recname,stat=ierr) if(allocated(gfile%reclevtyp)) deallocate(gfile%reclevtyp,stat=ierr) if(allocated(gfile%reclev)) deallocate(gfile%reclev,stat=ierr) endif if(gfile%nmeta>5_i_kind) then if(allocated(gfile%vcoord)) deallocate(gfile%vcoord,stat=ierr) endif if(gfile%nmeta>6_i_kind) then if(allocated(gfile%lat)) deallocate(gfile%lat,stat=ierr) if(allocated(gfile%lon)) deallocate(gfile%lon,stat=ierr) if(allocated(gfile%dx)) deallocate(gfile%dx,stat=ierr) if(allocated(gfile%dy)) deallocate(gfile%dy,stat=ierr) endif if(gfile%nmeta>10_i_kind) then if(allocated(gfile%Cpi)) deallocate(gfile%Cpi,stat=ierr) if(allocated(gfile%Ri)) deallocate(gfile%Ri,stat=ierr) endif ! gfile%mbuf=izero gfile%nnum=izero gfile%nlen=izero gfile%mnum=izero if(allocated(gfile%cbuf)) deallocate(gfile%cbuf) if(allocated(gfile%headvariname)) deallocate(gfile%headvariname,stat=ierr) if(allocated(gfile%headvarrname)) deallocate(gfile%headvarrname,stat=ierr) if(allocated(gfile%headvarlname)) deallocate(gfile%headvarlname,stat=ierr) if(allocated(gfile%headvarcname)) deallocate(gfile%headvarcname,stat=ierr) if(allocated(gfile%headvarival)) deallocate(gfile%headvarival,stat=ierr) if(allocated(gfile%headvarrval)) deallocate(gfile%headvarrval,stat=ierr) if(allocated(gfile%headvarlval)) deallocate(gfile%headvarlval,stat=ierr) if(allocated(gfile%headvarcval)) deallocate(gfile%headvarcval,stat=ierr) if(allocated(gfile%headaryiname)) deallocate(gfile%headaryiname,stat=ierr) if(allocated(gfile%headaryrname)) deallocate(gfile%headaryrname,stat=ierr) if(allocated(gfile%headarycname)) deallocate(gfile%headarycname,stat=ierr) if(allocated(gfile%headaryival)) deallocate(gfile%headaryival,stat=ierr) if(allocated(gfile%headaryrval)) deallocate(gfile%headaryrval,stat=ierr) if(allocated(gfile%headarycval)) deallocate(gfile%headarycval,stat=ierr) ! iret=izero ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_axmeta !------------------------------------------------------------------------------ subroutine nemsio_setfhead(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_setfhead ! prgmmr: ! ! abstract: required file header (default) ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret integer(i_kind) :: i,j,k ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-17_i_kind gfile%headvarinum=29_i_kind gfile%headvarrnum=4_i_kind gfile%headvarlnum=ione gfile%headvarcnum=3_i_kind ! if(gfile%nmeta>4_i_kind) then gfile%headaryinum=2_i_kind else gfile%headaryinum=ione endif ! if(gfile%nmeta>11_i_kind) then gfile%headaryrnum=7_i_kind elseif(gfile%nmeta>10_i_kind) then gfile%headaryrnum=6_i_kind elseif(gfile%nmeta>9_i_kind) then gfile%headaryrnum=5_i_kind elseif(gfile%nmeta>8_i_kind) then gfile%headaryrnum=4_i_kind elseif(gfile%nmeta>7_i_kind) then gfile%headaryrnum=3_i_kind elseif(gfile%nmeta>6_i_kind) then gfile%headaryrnum=2_i_kind elseif(gfile%nmeta>5_i_kind) then gfile%headaryrnum=ione endif ! if(gfile%nmeta>3_i_kind) then gfile%headarycnum=2_i_kind elseif(gfile%nmeta>2_i_kind) then gfile%headarycnum=ione else gfile%headarycnum=izero endif ! ! print*,'in setfhead,before headvariname,headvarival' allocate(gfile%headvariname(gfile%headvarinum),gfile%headvarival(gfile%headvarinum) ) gfile%headvariname(1)='version' gfile%headvarival(1)=gfile%version gfile%headvariname(2)='nmeta' gfile%headvarival(2)=gfile%nmeta gfile%headvariname(3)='lmeta' gfile%headvarival(3)=gfile%lmeta gfile%headvariname(4)='nrec' gfile%headvarival(4)=gfile%nrec gfile%headvariname(5)='nfday' gfile%headvarival(5)=gfile%nfday gfile%headvariname(6)='nfhour' gfile%headvarival(6)=gfile%nfhour gfile%headvariname(7)='nfminute' gfile%headvarival(7)=gfile%nfminute gfile%headvariname(8)='nfsecondn' gfile%headvarival(8)=gfile%nfsecondn gfile%headvariname(9)='nfsecondd' gfile%headvarival(9)=gfile%nfsecondd gfile%headvariname(10)='dimx' gfile%headvarival(10)=gfile%dimx gfile%headvariname(11)='dimy' gfile%headvarival(11)=gfile%dimy gfile%headvariname(12)='dimz' gfile%headvarival(12)=gfile%dimz gfile%headvariname(13)='nframe' gfile%headvarival(13)=gfile%nframe gfile%headvariname(14)='nsoil' gfile%headvarival(14)=gfile%nsoil gfile%headvariname(15)='ntrac' gfile%headvarival(15)=gfile%ntrac gfile%headvariname(16)='jcap' gfile%headvarival(16)=gfile%jcap gfile%headvariname(17)='ncldt' gfile%headvarival(17)=gfile%ncldt gfile%headvariname(18)='idvc' gfile%headvarival(18)=gfile%idvc gfile%headvariname(19)='idsl' gfile%headvarival(19)=gfile%idsl gfile%headvariname(20)='idvm' gfile%headvarival(20)=gfile%idvm gfile%headvariname(21)='idrt' gfile%headvarival(21)=gfile%idrt gfile%headvariname(22)='nmetavari' gfile%headvarival(22)=gfile%nmetavari gfile%headvariname(23)='nmetavarr' gfile%headvarival(23)=gfile%nmetavarr gfile%headvariname(24)='nmetavarl' gfile%headvarival(24)=gfile%nmetavarl gfile%headvariname(25)='nmetavarc' gfile%headvarival(25)=gfile%nmetavarc gfile%headvariname(26)='nmetaaryi' gfile%headvarival(26)=gfile%nmetaaryi gfile%headvariname(27)='nmetaaryr' gfile%headvarival(27)=gfile%nmetaaryr gfile%headvariname(28)='nmetaaryl' gfile%headvarival(28)=gfile%nmetaaryl gfile%headvariname(29)='nmetaaryc' gfile%headvarival(29)=gfile%nmetaaryc ! allocate(gfile%headvarrname(gfile%headvarrnum),gfile%headvarrval(gfile%headvarrnum) ) gfile%headvarrname(1)='rlon_min' gfile%headvarrval(1)=gfile%rlon_min gfile%headvarrname(2)='rlon_max' gfile%headvarrval(2)=gfile%rlon_max gfile%headvarrname(3)='rlat_min' gfile%headvarrval(3)=gfile%rlat_min gfile%headvarrname(4)='rlat_min' gfile%headvarrval(4)=gfile%rlat_min ! allocate(gfile%headvarcname(gfile%headvarcnum),gfile%headvarcval(gfile%headvarcnum) ) gfile%headvarcname(1)='gtype' gfile%headvarcval(1)=gfile%gtype gfile%headvarcname(2)='modelname' gfile%headvarcval(2)=gfile%modelname gfile%headvarcname(3)='gdatatype' gfile%headvarcval(3)=gfile%gdatatype !head logic var allocate(gfile%headvarlname(gfile%headvarlnum),gfile%headvarlval(gfile%headvarlnum) ) gfile%headvarlname(1)='extrameta' gfile%headvarlval(1)=gfile%extrameta ! !--- gfile%head int ary ! print *,'before setfhead, headaryi,nrec=',gfile%nrec,gfile%headaryinum allocate(gfile%headaryiname(gfile%headaryinum) ) allocate(gfile%headaryival(max(size(gfile%reclev),7),gfile%headaryinum)) gfile%headaryiname(1)='idate' gfile%headaryival(1:7,1)=gfile%idate(1:7) if(gfile%headaryinum>ione) then gfile%headaryiname(2)='reclev' gfile%headaryival(:,2)=gfile%reclev(:) endif ! !--- gfile%head real ary if(gfile%headaryrnum>izero) then if(.not.allocated(gfile%headaryrname)) allocate(gfile%headaryrname(gfile%headaryrnum) ) if(.not.allocated(gfile%headaryrval)) & allocate(gfile%headaryrval(max(gfile%fieldsize,(gfile%dimz+ione)*6),gfile%headaryrnum)) gfile%headaryrname(1)='vcoord' do j=1,2 do i=1,3 do k=1,gfile%dimz+ione gfile%headaryrval(k+((j-ione)*3+i-ione)*(gfile%dimz+ione),1)=gfile%vcoord(k,i,j) enddo enddo enddo if(gfile%headaryrnum>ione) then gfile%headaryrname(2)='lat' gfile%headaryrval(:,2)=gfile%lat endif if(gfile%headaryrnum>2_i_kind) then gfile%headaryrname(3)='lon' gfile%headaryrval(:,3)=gfile%lon endif if(gfile%headaryrnum>3_i_kind) then gfile%headaryrname(4)='dx' gfile%headaryrval(:,4)=gfile%dx endif if(gfile%headaryrnum>4_i_kind) then gfile%headaryrname(5)='dy' gfile%headaryrval(:,5)=gfile%dy endif if(gfile%headaryrnum>5_i_kind) then gfile%headaryrname(6)='cpi' gfile%headaryrval(1:size(gfile%cpi),6)=gfile%cpi endif if(gfile%headaryrnum>6_i_kind) then gfile%headaryrname(7)='ri' gfile%headaryrval(1:size(gfile%ri),7)=gfile%ri endif endif ! !--- gfile%head char var ! print *,'before setfhead, headaryc,nrec=',gfile%nrec,gfile%headarycnum if(gfile%headarycnum >izero) then allocate(gfile%headarycname(gfile%headarycnum) ) allocate(gfile%headarycval(size(gfile%recname),gfile%headarycnum)) gfile%headarycname(1)='recname' gfile%headarycval(:,1)=gfile%recname if(gfile%headarycnum >ione) then gfile%headarycname(2)='reclevtyp' gfile%headarycval(:,2)=gfile%reclevtyp endif endif ! iret=izero end subroutine nemsio_setfhead !------------------------------------------------------------------------------ subroutine nemsio_setgrbtbl(iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_setgrbtbl ! prgmmr: ! ! abstract: set up grib table ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! ! output argument list: ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none integer(i_kind),intent( out) :: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-7_i_kind gribtable(1)%iptv=2_i_kind gribtable(1)%item(1)=nemsio_grbtbl_item('hgt','sfc',1,0,7,1) gribtable(1)%item(2)=nemsio_grbtbl_item('pres','sfc',0,0,1,1) gribtable(1)%item(3)=nemsio_grbtbl_item('pres','mid layer',0,0,1,109) gribtable(1)%item(4)=nemsio_grbtbl_item('dpres','mid layer',2,0,1,110) gribtable(1)%item(5)=nemsio_grbtbl_item('tmp','mid layer',2,0,11,109) gribtable(1)%item(6)=nemsio_grbtbl_item('ugrd','mid layer',2,0,33,109) gribtable(1)%item(7)=nemsio_grbtbl_item('vgrd','mid layer',2,0,34,109) gribtable(1)%item(8)=nemsio_grbtbl_item('spfh','mid layer',7,0,51,109) gribtable(1)%item(9)=nemsio_grbtbl_item('o3mr','mid layer',9,0,154,109) gribtable(1)%item(10)=nemsio_grbtbl_item('clwmr','mid layer',7,0,153,109) ! gribtable(1)%item(11)=nemsio_grbtbl_item('vvel','mid layer',9,0,39,109) gribtable(1)%item(12)=nemsio_grbtbl_item('tmp','sfc',3,0,11,1) gribtable(1)%item(13)=nemsio_grbtbl_item('soilw','0-10 cm down',4,10,144,112) gribtable(1)%item(14)=nemsio_grbtbl_item('soilw','10-40 cm down',4,2600,144,112) gribtable(1)%item(15)=nemsio_grbtbl_item('soilw','40-100 cm down',4,10340,144,112) gribtable(1)%item(16)=nemsio_grbtbl_item('soilw','100-200 cm down',4,25800,144,112) gribtable(1)%item(17)=nemsio_grbtbl_item('tmp','0-10 cm down',3,10,11,112) gribtable(1)%item(18)=nemsio_grbtbl_item('tmp','10-40 cm down',3,2600,11,112) gribtable(1)%item(19)=nemsio_grbtbl_item('tmp','40-100 cm down',3,10340,11,112) gribtable(1)%item(20)=nemsio_grbtbl_item('tmp','100-200 cm down',3,25800,11,112) ! gribtable(1)%item(21)=nemsio_grbtbl_item('weasd','sfc',5,0,65,1) gribtable(1)%item(22)=nemsio_grbtbl_item('tg3','sfc',2,0,11,111) gribtable(1)%item(23)=nemsio_grbtbl_item('sfcr','sfc',4,0,83,1) gribtable(1)%item(24)=nemsio_grbtbl_item('tcdc','high cld lay',0,0,71,234) gribtable(1)%item(25)=nemsio_grbtbl_item('pres','high cld top',-1,0,1,233) gribtable(1)%item(26)=nemsio_grbtbl_item('pres','high cld bot',-1,0,1,232) gribtable(1)%item(27)=nemsio_grbtbl_item('tmp','high cld top',3,0,11,233) gribtable(1)%item(28)=nemsio_grbtbl_item('tcdc','mid cld lay',0,0,71,224) gribtable(1)%item(29)=nemsio_grbtbl_item('pres','mid cld top',-1,0,1,223) gribtable(1)%item(30)=nemsio_grbtbl_item('pres','mid cld bot',-1,0,1,222) ! gribtable(1)%item(31)=nemsio_grbtbl_item('tmp','mid cld top',3,0,11,223) gribtable(1)%item(32)=nemsio_grbtbl_item('tcdc','low cld lay',0,0,71,214) gribtable(1)%item(33)=nemsio_grbtbl_item('pres','low cld top',-1,0,1,213) gribtable(1)%item(34)=nemsio_grbtbl_item('pres','low cld bot',-1,0,1,212) gribtable(1)%item(35)=nemsio_grbtbl_item('tmp','low cld top',3,0,11,213) gribtable(1)%item(36)=nemsio_grbtbl_item('tcdc','atmos col',0,0,71,200) !orog??? gribtable(1)%item(37)=nemsio_grbtbl_item('tcdc','convect-cld laye',3,0,71,244) !orog??? gribtable(1)%item(38)=nemsio_grbtbl_item('pres','convect-cld bot',-1,0,1,242) gribtable(1)%item(39)=nemsio_grbtbl_item('pres','convect-cld top',-1,0,1,243) gribtable(1)%item(40)=nemsio_grbtbl_item('tcdc','bndary-layer cld',3,0,71,211) !orog??? ! gribtable(1)%item(41)=nemsio_grbtbl_item('alvsf','sfc',3,0,176,1) gribtable(1)%item(42)=nemsio_grbtbl_item('alvwf','sfc',3,0,177,1) gribtable(1)%item(43)=nemsio_grbtbl_item('alnsf','sfc',3,0,178,1) gribtable(1)%item(44)=nemsio_grbtbl_item('alnwf','sfc',3,0,179,1) gribtable(1)%item(45)=nemsio_grbtbl_item('land','sfc',0,0,81,1) gribtable(1)%item(46)=nemsio_grbtbl_item('veg','sfc',2,0,87,1) gribtable(1)%item(47)=nemsio_grbtbl_item('cnwat','sfc',5,0,223,1) gribtable(1)%item(48)=nemsio_grbtbl_item('f10m','10 m above gnd',5,10,180,105) gribtable(1)%item(49)=nemsio_grbtbl_item('ugrd','10 m above gnd',2,10,33,105) gribtable(1)%item(50)=nemsio_grbtbl_item('vgrd','10 m above gnd',2,10,34,105) ! gribtable(1)%item(51)=nemsio_grbtbl_item('tmp','2 m above gnd',3,2,11,105) gribtable(1)%item(52)=nemsio_grbtbl_item('spfh','2 m above gnd',6,2,51,105) gribtable(1)%item(53)=nemsio_grbtbl_item('vtype','sfc',1,0,225,1) gribtable(1)%item(54)=nemsio_grbtbl_item('facsf','sfc',3,0,207,1) gribtable(1)%item(55)=nemsio_grbtbl_item('facsf','sfc',3,0,208,1) gribtable(1)%item(56)=nemsio_grbtbl_item('fricv','sfc',3,0,253,1) gribtable(1)%item(57)=nemsio_grbtbl_item('ffmm','sfc',3,0,253,1) !??? gribtable(1)%item(58)=nemsio_grbtbl_item('ffhh','sfc',3,0,253,1) !??? gribtable(1)%item(59)=nemsio_grbtbl_item('icetk','sfc',2,0,92,1) gribtable(1)%item(60)=nemsio_grbtbl_item('icec','sfc',3,0,91,1) ! gribtable(1)%item(61)=nemsio_grbtbl_item('tisfc','sfc',2,0,171,1) gribtable(1)%item(62)=nemsio_grbtbl_item('tprcp','sfc',2,0,171,1) !tprc ??? gribtable(1)%item(63)=nemsio_grbtbl_item('crain','sfc',0,0,140,1) !srflag ??? gribtable(1)%item(64)=nemsio_grbtbl_item('snod','sfc',6,0,66,1) gribtable(1)%item(65)=nemsio_grbtbl_item('slc','soil layer',3,130,160,112) gribtable(1)%item(66)=nemsio_grbtbl_item('shdmin','sfc',3,0,189,1) gribtable(1)%item(67)=nemsio_grbtbl_item('shdmax','sfc',3,0,190,1) gribtable(1)%item(68)=nemsio_grbtbl_item('sotyp','sfc',1,0,224,1) gribtable(1)%item(69)=nemsio_grbtbl_item('salbd','sfc',1,0,194,1) !jw gribtable(1)%item(49)=nemsio_grbtbl_item('orog','sfc',1,0,194,1) !orog??? !flx gribtable(1)%item(70)=nemsio_grbtbl_item('uflx','sfc',3,0,124,1) ! gribtable(1)%item(71)=nemsio_grbtbl_item('vflx','sfc',3,0,125,1) gribtable(1)%item(72)=nemsio_grbtbl_item('shtfl','sfc',0,0,122,1) gribtable(1)%item(73)=nemsio_grbtbl_item('lhtfl','sfc',0,0,121,1) gribtable(1)%item(74)=nemsio_grbtbl_item('dlwrf','sfc',0,0,205,1) gribtable(1)%item(75)=nemsio_grbtbl_item('ulwrf','sfc',0,0,212,1) gribtable(1)%item(76)=nemsio_grbtbl_item('ulwrf','nom. top',0,0,212,8) gribtable(1)%item(77)=nemsio_grbtbl_item('uswrf','nom. top',0,0,211,8) gribtable(1)%item(78)=nemsio_grbtbl_item('uswrf','sfc',0,0,211,1) gribtable(1)%item(79)=nemsio_grbtbl_item('dswrf','sfc',0,0,204,1) gribtable(1)%item(80)=nemsio_grbtbl_item('prate','sfc',6,0,59,1) gribtable(1)%item(81)=nemsio_grbtbl_item('soilm','0-200 cm down',4,200,86,112) gribtable(1)%item(82)=nemsio_grbtbl_item('vgtyp','sfc',1,0,225,1) gribtable(1)%item(83)=nemsio_grbtbl_item('cprat','sfc',6,0,214,1) gribtable(1)%item(84)=nemsio_grbtbl_item('gflux','sfc',0,0,155,1) gribtable(1)%item(85)=nemsio_grbtbl_item('tmax','2 m above gnd',1,2,15,105) gribtable(1)%item(86)=nemsio_grbtbl_item('tmin','2 m above gnd',1,2,16,105) gribtable(1)%item(87)=nemsio_grbtbl_item('watr','sfc',5,0,90,1) gribtable(1)%item(88)=nemsio_grbtbl_item('pevpr','sfc',0,0,145,1) gribtable(1)%item(89)=nemsio_grbtbl_item('cwork','atmos col',0,0,146,200) gribtable(1)%item(90)=nemsio_grbtbl_item('u-gwd','sfc',3,0,147,1) ! gribtable(1)%item(91)=nemsio_grbtbl_item('v-gwd','sfc',3,0,148,1) gribtable(1)%item(92)=nemsio_grbtbl_item('hpbl','sfc',0,0,221,1) gribtable(1)%item(93)=nemsio_grbtbl_item('pwat','atmos col',1,0,54,200) gribtable(1)%item(94)=nemsio_grbtbl_item('albdo','sfc',1,0,84,1) gribtable(1)%item(95)=nemsio_grbtbl_item('cnwat','sfc',5,0,223,1) gribtable(1)%item(96)=nemsio_grbtbl_item('sfexc','sfc',4,0,208,1) gribtable(1)%item(97)=nemsio_grbtbl_item('pevpr','sfc',0,0,145,1) gribtable(1)%item(98)=nemsio_grbtbl_item('dlwrf','sfc',0,0,205,1) gribtable(1)%item(99)=nemsio_grbtbl_item('ulwrf','sfc',0,0,212,1) gribtable(1)%item(100)=nemsio_grbtbl_item('uswrf','sfc',0,0,211,1) ! gribtable(1)%item(101)=nemsio_grbtbl_item('dswrf','sfc',0,0,204,1) gribtable(1)%item(102)=nemsio_grbtbl_item('ssrun','sfc',5,0,235,1) gribtable(1)%item(103)=nemsio_grbtbl_item('tmp','hybrid lev 1',3,1,11,109) gribtable(1)%item(104)=nemsio_grbtbl_item('spfh','hybrid lev 1',6,1,51,109) gribtable(1)%item(105)=nemsio_grbtbl_item('ugrd','hybrid lev 1',2,1,33,109) gribtable(1)%item(106)=nemsio_grbtbl_item('vgrd','hybrid lev 1',2,1,34,109) gribtable(1)%item(107)=nemsio_grbtbl_item('hgt','hybrid lev 1',2,1,7,109) gribtable(1)%item(108)=nemsio_grbtbl_item('evbs','sfc',0,0,199,1) gribtable(1)%item(109)=nemsio_grbtbl_item('evcw','sfc',0,0,200,1) gribtable(1)%item(110)=nemsio_grbtbl_item('trans','sfc',0,0,210,1) gribtable(1)%item(111)=nemsio_grbtbl_item('snowc','sfc',3,0,238,1) ! ! gribtable(1)%item(50)=nemsio_grbtbl_item('nlat','sfc',2,0,176,1) ! gribtable(1)%item(51)=nemsio_grbtbl_item('elon','sfc',2,0,177,1) ! gribtable(1)%item(52)=nemsio_grbtbl_item('nlonb','sfc',2,0,177,1) !vlat ??? ! gribtable(1)%item(53)=nemsio_grbtbl_item('elonb','sfc',2,0,177,1) !vlon ??? ! gribtable(1)%item(54)=nemsio_grbtbl_item('wtend','sfc',6,0,236,1) !wtend precision ! gribtable(1)%item(55)=nemsio_grbtbl_item('omgalf','sfc',6,0,154,1) !wtend precision ! gribtable(1)%item(56)=nemsio_grbtbl_item('omgalf','sfc',6,0,154,1) !wtend precision ! !*** table 129 gribtable(2)%iptv=129_i_kind gribtable(2)%item(1)=nemsio_grbtbl_item('duvb','sfc',2,0,200,1) gribtable(2)%item(2)=nemsio_grbtbl_item('cduvb','sfc',2,0,201,1) ! !*** table 130 gribtable(3)%iptv=130_i_kind gribtable(3)%item(1)=nemsio_grbtbl_item('sltyp','sfc',0,0,222,1) gribtable(3)%item(2)=nemsio_grbtbl_item('sbsno','sfc',0,0,198,1) gribtable(3)%item(3)=nemsio_grbtbl_item('soill','0-10 cm down',4,10,160,112) gribtable(3)%item(4)=nemsio_grbtbl_item('soill','10-40 cm down',4,2600,160,112) gribtable(3)%item(5)=nemsio_grbtbl_item('soill','40-100 cm down',4,10340,160,112) gribtable(3)%item(6)=nemsio_grbtbl_item('soill','100-200 cm down',4,25800,160,112) gribtable(3)%item(7)=nemsio_grbtbl_item('acond','sfc',4,0,179,1) ! iret=izero end subroutine nemsio_setgrbtbl !------------------------------------------------------------------------------ subroutine nemsio_gfinit(gfile,iret,recname,reclevtyp,reclev) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_gfinit ! prgmmr: ! ! abstract: set gfile variables to operational model output ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! recname ! reclevtyp ! reclev ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile) ,intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret character(*) ,optional,intent(in ) :: recname(:) character(*) ,optional,intent(in ) :: reclevtyp(:) integer(i_kind),optional,intent(in ) :: reclev(:) integer(i_kind) :: i,j,rec real(r_kind),allocatable :: slat(:) real(r_kind),allocatable :: dx(:) real(r_kind) :: radi logical(nemsio_logickind) :: linit ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! set operational format ! iret=-8_i_kind gfile%version=200809_i_kind gfile%nfday=izero gfile%nfhour=izero gfile%nfminute=izero gfile%nfsecondn=izero gfile%nfsecondd=100_i_kind gfile%extrameta=.false. gfile%nmetavari=izero gfile%nmetavarr=izero gfile%nmetavarl=izero gfile%nmetavarc=izero gfile%nmetaaryi=izero gfile%nmetaaryr=izero gfile%nmetaaryl=izero gfile%nmetaaryc=izero ! write(0,*)'in gfinit, modelname=',gfile%modelname if ( gfile%modelname == 'GFS') then if(gfile%dimy==nemsio_intfill) gfile%dimy=576_i_kind if(gfile%dimx==nemsio_intfill) gfile%dimx=1152_i_kind if(gfile%dimz==nemsio_intfill) gfile%dimz=64_i_kind if(gfile%nframe==nemsio_intfill) gfile%nframe=izero if(gfile%ntrac==nemsio_intfill) gfile%ntrac=3_i_kind if(gfile%nrec==nemsio_intfill)gfile%nrec=2_i_kind+9*gfile%dimz+35_i_kind+3*gfile%nsoil gfile%ncldt=ione gfile%idsl=izero gfile%idvm=izero gfile%idrt=4_i_kind linit=gfile%dimy==576_i_kind.and.gfile%dimx==1152_i_kind.and.gfile%dimz==64_i_kind gfile%extrameta=.True. gfile%nmetavari=5_i_kind if(linit) then gfile%jcap=382_i_kind gfile%idvc=2_i_kind gfile%nmetavari=15_i_kind gfile%nmetavarr=ione gfile%nmetaaryi=ione endif else if (gfile%modelname == 'NMMB' ) then if(gfile%dimx==nemsio_intfill) gfile%dimx=257_i_kind if(gfile%dimy==nemsio_intfill) gfile%dimy=181_i_kind if(gfile%dimz==nemsio_intfill) gfile%dimz=35_i_kind if(gfile%nframe==nemsio_intfill) gfile%nframe=ione if(gfile%ntrac==nemsio_intfill) gfile%ntrac=4_i_kind if(gfile%nrec==nemsio_intfill) & gfile%nrec=86_i_kind+20*gfile%dimz+(gfile%dimz+1)+3*gfile%nsoil+4_i_kind linit=gfile%dimx==257_i_kind.and.gfile%dimy==181_i_kind.and.gfile%dimz==35_i_kind if(linit) then gfile%extrameta=.True. gfile%nmetavari=9_i_kind gfile%nmetavarr=12_i_kind gfile%nmetavarl=2_i_kind gfile%nmetaaryr=7_i_kind gfile%rlon_min=-178.5937347_r_single gfile%rlon_max=178.5937347_r_single gfile%rlat_min=-89.49999237_r_single gfile%rlat_max=89.49999237_r_single endif ! print *,'in gfinit, nrec=',gfile%nrec else if (gfile%modelname== "GSI" ) then if(gfile%dimx==nemsio_intfill) gfile%dimx=1152_i_kind if(gfile%dimy==nemsio_intfill) gfile%dimy=576_i_kind if(gfile%dimz==nemsio_intfill) gfile%dimz=64_i_kind if(gfile%nrec==nemsio_intfill) & gfile%nrec=10_i_kind+3*gfile%dimz+gfile%ntrac*gfile%dimz linit=gfile%dimx==1152_i_kind.and.gfile%dimy==576_i_kind.and.gfile%dimz==64_i_kind if(linit) then gfile%jcap=382_i_kind gfile%idvc=2_i_kind gfile%ncldt=ione gfile%idsl=izero gfile%idvm=izero gfile%idrt=4_i_kind gfile%extrameta=.True. gfile%nmetaaryc=ione endif endif if(gfile%dimx==nemsio_intfill.or.gfile%dimy==nemsio_intfill.or. & gfile%dimz==nemsio_intfill.or.gfile%idate(1)==nemsio_intfill) then print *,'WRONG: please provide dimensions!' call nemsio_stop endif if(gfile%nframe==nemsio_intfill) gfile%nframe=izero gfile%fieldsize=(gfile%dimx+2*gfile%nframe)*(gfile%dimy+2*gfile%nframe) if(gfile%nrec==nemsio_intfill) gfile%nrec=12_i_kind+(3_i_kind+gfile%ntrac)*gfile%dimz ! ! print *,'gfinit, after set up dimension,',gfile%nrec,gfile%ntrac,gfile%fieldsize,& ! gfile%dimz call nemsio_almeta(gfile,iret) if ( iret/=izero ) return call nemsio_alextrameta(gfile,iret) if ( iret/=izero ) return ! print *,'gfinit, after set up allocate array size dx',size(gfile%dx),size(gfile%cpi), & ! size(gfile%variname), size(gfile%varrname),size(gfile%varlname),size(gfile%aryrname),& ! gfile%nmetavari,gfile%nmetavarr,gfile%nmetavarl,gfile%nmetaaryr,gfile%nmetaaryi ! ! if ( gfile%modelname == 'GFS' ) then gfile%variname=(/'itrun ','iorder ','irealf ','igen ','icen2 '/) gfile%varival=(/ione,2_i_kind,ione,82_i_kind,izero/) if(linit) then gfile%variname=(/'itrun ','iorder ','irealf ','igen ','latf ','lonf ','latr ','lonr ', & 'icen2 ','idpp ','idvt ','idrun ','idusr ','ixgr ','nvcoord'/) gfile%varival=(/ione,2_i_kind,ione,82_i_kind,576_i_kind,1152_i_kind,576_i_kind,1152_i_kind,izero, & 21_i_kind,izero,izero,izero,izero,2_i_kind/) gfile%varrname=(/'pdryini'/) gfile%varrval=(/98.29073_r_single/) gfile%aryiname(1)='iens' gfile%aryilen(1)=2_i_kind allocate(gfile%aryival(maxval(gfile%aryilen),gfile%nmetaaryi)) gfile%aryival(:,1)=(/izero,izero/) ! print *,'before gfile vcoord',size(gfile%vcoord,1),size(gfile%vcoord,2),size(gfile%vcoord,3) if(gfile%dimz==64_i_kind) then gfile%vcoord(1:gfile%dimz+ione,1,1)=(/2*0.0000000_r_single,0.57499999_r_single,5.7410002_r_single,21.516001_r_single,55.712002_r_single, & 116.89900_r_single,214.01500_r_single,356.22299_r_single,552.71997_r_single,812.48901_r_single,1143.9880_r_single,1554.7889_r_single, & 2051.1499_r_single,2637.5530_r_single,3316.2170_r_single,4086.6140_r_single,4945.0288_r_single,5884.2061_r_single,6893.1172_r_single, & 7956.9082_r_single,9057.0508_r_single,10171.712_r_single,11276.348_r_single,12344.490_r_single,13348.671_r_single,14261.435_r_single, & 15056.342_r_single,15708.893_r_single,16197.315_r_single,16503.145_r_single,16611.604_r_single,16511.736_r_single,16197.967_r_single, & 15683.489_r_single,14993.074_r_single,14154.316_r_single,13197.065_r_single,12152.937_r_single,11054.853_r_single,9936.6143_r_single, & 8832.5371_r_single,7777.1499_r_single,6804.8740_r_single,5937.0498_r_single,5167.1460_r_single,4485.4932_r_single,3883.0520_r_single, & 3351.4600_r_single,2883.0381_r_single,2470.7881_r_single,2108.3660_r_single,1790.0510_r_single,1510.7111_r_single,1265.7520_r_single, & 1051.0800_r_single,863.05798_r_single,698.45697_r_single,554.42401_r_single,428.43399_r_single,318.26599_r_single,221.95799_r_single, & 137.78999_r_single,64.247002_r_single,0.0000000_r_single /) gfile%vcoord(1:gfile%dimz+ione,2,1)=(/1.0000000_r_single,0.99467117_r_single,0.98862660_r_single,0.98174226_r_single,0.97386760_r_single, & 0.96482760_r_single,0.95443410_r_single,0.94249105_r_single,0.92879730_r_single,0.91315103_r_single,0.89535499_r_single, & 0.87522358_r_single,0.85259068_r_single,0.82731885_r_single,0.79930973_r_single,0.76851469_r_single,0.73494524_r_single, & 0.69868290_r_single,0.65988702_r_single,0.61879963_r_single,0.57574666_r_single,0.53113484_r_single,0.48544332_r_single, & 0.43921080_r_single,0.39301825_r_single,0.34746850_r_single,0.30316412_r_single,0.26068544_r_single,0.22057019_r_single, & 0.18329623_r_single,0.14926878_r_single,0.11881219_r_single,0.92166908E-01_r_single,0.69474578E-01_r_single,0.50646842E-01_r_single, & 0.35441618E-01_r_single, 0.23555880E-01_r_single,0.14637120E-01_r_single,0.82940198E-02_r_single,0.41067102E-02_r_single, & 0.16359100E-02_r_single,0.43106001E-03_r_single,0.36969999E-04_r_single,0.0000000*22_r_single /) gfile%vcoord(1:gfile%dimz+ione,3,1)=zero gfile%vcoord(1:gfile%dimz+ione,1,2)=zero gfile%vcoord(1:gfile%dimz+ione,2,2)=zero gfile%vcoord(1:gfile%dimz+ione,3,2)=zero endif if(.not.present(recname).or..not.present(reclevtyp).or..not.present(reclev) )then if(size(gfile%recname)==2_i_kind+9*gfile%dimz+35_i_kind+3*gfile%nsoil) then rec=ione gfile%recname(rec)='hgt' gfile%recname(rec+ione)='pres' gfile%recname(rec+2_i_kind:rec+gfile%dimz+ione)='pres' gfile%recname(rec+gfile%dimz+2_i_kind:rec+2*gfile%dimz+ione)='dpres' gfile%recname(rec+2*gfile%dimz+2_i_kind:rec+3*gfile%dimz+ione)='tmp' gfile%recname(rec+3*gfile%dimz+2_i_kind:rec+4*gfile%dimz+ione)='ugrd' gfile%recname(rec+4*gfile%dimz+2_i_kind:rec+5*gfile%dimz+ione)='vgrd' gfile%recname(rec+5*gfile%dimz+2_i_kind:rec+6*gfile%dimz+ione)='spfh' gfile%recname(rec+6*gfile%dimz+2_i_kind:rec+7*gfile%dimz+ione)='o3mr' gfile%recname(rec+7*gfile%dimz+2_i_kind:rec+8*gfile%dimz+ione)='clwmr' gfile%recname(rec+8*gfile%dimz+2_i_kind:rec+9*gfile%dimz+ione)='vvel' rec=rec+9*gfile%dimz+ione gfile%recname(rec+ione:rec+35_i_kind)=(/'slmsk ','orog ','tsea ','sheleg','tg3 ','zorl ', & 'cv ','cvb ','cvt ', & 'alvsf ','alvwf ','alnsf ','alnwf ','vfrac ','canopy','f10m ','t2m ', & 'q2m ','vtype ','stype ','facsf ','facwf ','uustar','ffmm ','ffhh ', & 'hice ','fice ','tisfc ','tprcp ','srflag','snwdph','shdmin','shdmax', & 'slope ','snoalb' /) gfile%recname(rec+36_i_kind:rec+35_i_kind+gfile%nsoil)='stc' gfile%recname(rec+36_i_kind+gfile%nsoil:rec+35_i_kind+2*gfile%nsoil)='smc' gfile%recname(rec+36_i_kind+2*gfile%nsoil:rec+35_i_kind+3*gfile%nsoil)='slc' endif if(size(gfile%reclevtyp)==2_i_kind+9*gfile%dimz+35_i_kind+3*gfile%nsoil) then rec=ione gfile%reclevtyp='sfc' gfile%reclevtyp(rec+2_i_kind:rec+gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+gfile%dimz+2_i_kind:rec+2*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+2*gfile%dimz+2_i_kind:rec+3*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+3*gfile%dimz+2_i_kind:rec+4*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+4*gfile%dimz+2_i_kind:rec+5*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+5*gfile%dimz+2_i_kind:rec+6*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+6*gfile%dimz+2_i_kind:rec+7*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+7*gfile%dimz+2_i_kind:rec+8*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+8*gfile%dimz+2_i_kind:rec+9*gfile%dimz+ione)='mid layer' rec=rec+9*gfile%dimz+36_i_kind gfile%reclevtyp(rec+ione:rec+3*gfile%nsoil)='soil layer' endif ! if(size(gfile%reclev)==2_i_kind+9*gfile%dimz+35_i_kind+3*gfile%nsoil) then gfile%reclev=ione rec=2_i_kind do j=3,11 do i=1,gfile%dimz gfile%reclev(rec+(j-3_i_kind)*gfile%dimz+i)=i enddo enddo rec=rec+9*gfile%dimz+35_i_kind do j=1,3 do i=1,gfile%nsoil gfile%reclev(rec+(j-ione)*gfile%nsoil+i)=i enddo enddo endif ! endif endif ! !lat: allocate(slat(gfile%dimy)) call splat(gfile%idrt,gfile%dimy,slat) radi=180.0_r_kind/(four*atan(one)) do i=1,gfile%dimy gfile%lat((i-ione)*gfile%dimx+ione:i*gfile%dimx) = asin(slat(i)) * radi enddo deallocate(slat) !lon: do i=1,gfile%dimx gfile%lon(i) = 360._r_single/gfile%dimx*(i-ione) enddo do j=2,gfile%dimy gfile%lon((j-ione)*gfile%dimx+ione:j*gfile%dimx) = gfile%lon(1:gfile%dimx) enddo ! write(0,*)'in gfinit, lat=',maxval(gfile%lat(1:gfile%fieldsize)), & ! minval(gfile%lat(1:gfile%fieldsize)),'lon=',& ! maxval(gfile%lon(1:gfile%fieldsize)), & ! minval(gfile%lon(1:gfile%fieldsize)) else if ( gfile%modelname == "NMMB" .and. linit) then gfile%variname=(/'mp_phys ','sfsfcphy','nphs ','nclod ', & 'nheat ','nprec ','nrdlw ','nrdsw ','nsrfc ' /) gfile%varival=(/5_i_kind,99_i_kind,2_i_kind,60_i_kind,60_i_kind,60_i_kind,60_i_kind,60_i_kind,60_i_kind/) gfile%varrname=(/'pdtop ','dt ','pt ','tlm0d ','tph0d ','tstart', & 'aphtim','ardlw ','ardsw ','asrfc ','avcnvc','avrain' /) gfile%varrval=(/26887.10156_r_single,180._r_single,1000._r_single,0._r_single,0._r_single,0._r_single,-1000000.0_r_single, & -1000000.0_r_single,-1000000.0_r_single,-1000000.0_r_single,0._r_single,0._r_single/) gfile%varlname=(/'run ','global'/) gfile%varlval=(/.true.,.false. /) gfile%aryrname=(/'dsg1 ','dsg2 ','sgml1 ','sgml2 ','sg1 ','sg2 ','sldpth'/) gfile%aryrlen=(/gfile%dimz,gfile%dimz,gfile%dimz,gfile%dimz, & gfile%dimz+ione,gfile%dimz+ione,gfile%nsoil /) allocate(gfile%aryrval(maxval(gfile%aryrlen),gfile%nmetaaryr)) if(size(gfile%aryrval,1)==36_i_kind) then gfile%aryrval(1:35,1)=(/0.8208955079E-01_r_single,0.8582090586E-01_r_single,0.8582088351E-01_r_single, & 0.8582088351E-01_r_single,0.8582091331E-01_r_single,0.8582085371E-01_r_single, & 0.9328359365E-01_r_single,0.9701490402E-01_r_single,0.9701496363E-01_r_single, & 0.9701490402E-01_r_single,0.1044776440_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single /) gfile%aryrval(1:35,2)=(/0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.4098360986E-01_r_single, & 0.4371585697E-01_r_single,0.4781420529E-01_r_single,0.4918029904E-01_r_single,0.5054645240E-01_r_single, & 0.5327869952E-01_r_single,0.5464482307E-01_r_single,0.5464476347E-01_r_single,0.5464485288E-01_r_single, & 0.5464485288E-01_r_single,0.5464470387E-01_r_single,0.5191260576E-01_r_single,0.5054640770E-01_r_single, & 0.4918038845E-01_r_single,0.4508191347E-01_r_single,0.4371589422E-01_r_single,0.3961753845E-01_r_single, & 0.3551906347E-01_r_single,0.3005468845E-01_r_single,0.2732235193E-01_r_single,0.2459019423E-01_r_single, & 0.1912564039E-01_r_single,0.1639348269E-01_r_single,0.8196711540E-02_r_single /) gfile%aryrval(1:35,3)=(/0.4104477540E-01_r_single,0.1250000000_r_single,0.2108208984_r_single,0.2966417670_r_single,0.3824626803_r_single, & 0.4682835639_r_single,0.5578358173_r_single,0.6529850364_r_single,0.7500000000_r_single,0.8470149040_r_single, & 0.9477611780_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single /) gfile%aryrval(1:35,4)=(/0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.2049180493E-01_r_single, & 0.6284153461E-01_r_single,0.1086065695_r_single,0.1571038216_r_single,0.2069672048_r_single,0.2588797808_r_single, & 0.3128415346_r_single,0.3674863279_r_single,0.4221311212_r_single,0.4767760038_r_single,0.5314207673_r_single, & 0.5846993923_r_single,0.6359289289_r_single,0.6857923269_r_single,0.7329235077_r_single,0.7773224115_r_single, & 0.8189890981_r_single,0.8565573692_r_single,0.8893442750_r_single,0.9180327654_r_single,0.9439890385_r_single, & 0.9658470154_r_single,0.9836065769_r_single,0.9959016442_r_single/) gfile%aryrval(1:36,5)=(/0.0000000000E+00_r_single,0.8208955079E-01_r_single,0.1679104567_r_single,0.2537313402_r_single, & 0.3395522237_r_single,0.4253731370_r_single,0.5111939907_r_single,0.6044775844_r_single,0.7014924884_r_single, & 0.7985074520_r_single,0.8955223560_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single,1.000000000_r_single, & 1.000000000_r_single,1.000000000_r_single /) gfile%aryrval(1:36,6)=(/0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single,0.0000000000E+00_r_single, & 0.4098360986E-01_r_single,0.8469946682E-01_r_single,0.1325136721_r_single,0.1816939712_r_single, & 0.2322404236_r_single,0.2855191231_r_single,0.3401639462_r_single,0.3948087096_r_single,0.4494535625_r_single, & 0.5040984154_r_single,0.5587431192_r_single,0.6106557250_r_single,0.6612021327_r_single,0.7103825212_r_single, & 0.7554644346_r_single,0.7991803288_r_single,0.8387978673_r_single,0.8743169308_r_single,0.9043716192_r_single, & 0.9316939712_r_single,0.9562841654_r_single,0.9754098058_r_single,0.9918032885_r_single,1.000000000_r_single /) gfile%aryrval(1,7)=0.1000000015_r_single gfile%aryrval(2,7)=0.3000000119_r_single gfile%aryrval(3,7)=0.6000000238_r_single gfile%aryrval(4,7)=1.000000000_r_single endif ! gfile%dy=111282.1953_r_single allocate(dx(gfile%dimy+2*gfile%nframe)) dx=zero if(size(dx)==183_i_kind) then dx(1:183)=(/2731.143066_r_single,0.0000000000E+00_r_single,2731.143066_r_single,5461.452148_r_single,8190.078125_r_single,10916.22852_r_single, & 13639.05469_r_single,16357.72461_r_single,19071.41211_r_single,21779.29102_r_single,24480.51758_r_single,27174.30469_r_single,29859.81250_r_single, & 32536.22656_r_single,35202.73047_r_single,37858.51172_r_single,40502.74219_r_single,43134.64844_r_single,45753.42188_r_single,48358.25781_r_single, & 50948.35938_r_single,53522.93750_r_single,56081.21094_r_single,58622.40625_r_single,61145.74609_r_single,63650.46094_r_single,66135.78906_r_single, & 68600.96094_r_single,71045.23438_r_single,73467.88281_r_single,75868.14844_r_single,78245.29688_r_single,80598.62500_r_single,82927.38281_r_single, & 85230.89062_r_single,87508.42969_r_single,89759.32031_r_single,91982.86719_r_single,94178.39062_r_single,96345.23438_r_single,98482.71875_r_single, & 100590.2188_r_single,102667.0625_r_single,104712.6406_r_single,106726.3281_r_single,108707.5000_r_single,110655.5625_r_single,112569.9062_r_single, & 114449.9844_r_single,116295.1719_r_single,118104.9531_r_single,119878.7500_r_single,121616.0312_r_single,123316.2656_r_single,124978.9453_r_single, & 126603.5469_r_single,128189.5938_r_single,129736.5781_r_single,131244.0625_r_single,132711.5625_r_single,134138.6250_r_single,135524.8438_r_single, & 136869.7500_r_single,138173.0000_r_single,139434.1406_r_single,140652.8125_r_single,141828.6406_r_single,142961.2812_r_single,144050.3438_r_single, & 145095.5469_r_single,146096.5625_r_single,147053.0625_r_single,147964.7656_r_single,148831.4062_r_single,149652.6875_r_single,150428.4062_r_single, & 151158.2969_r_single,151842.1562_r_single,152479.7500_r_single,153070.9062_r_single,153615.4219_r_single,154113.1562_r_single,154563.9375_r_single, & 154967.6406_r_single,155324.1406_r_single,155633.3281_r_single,155895.1094_r_single,156109.3906_r_single,156276.1250_r_single,156395.2656_r_single, & 156466.7656_r_single,156490.5938_r_single,156466.7656_r_single,156395.2656_r_single,156276.1250_r_single,156109.3906_r_single,155895.1094_r_single, & 155633.3281_r_single,155324.1406_r_single,154967.6406_r_single,154563.9375_r_single,154113.1562_r_single,153615.4219_r_single,153070.9062_r_single, & 152479.7500_r_single,151842.1562_r_single,151158.2969_r_single,150428.4062_r_single,149652.6875_r_single,148831.4062_r_single,147964.7656_r_single, & 147053.0625_r_single,146096.5625_r_single,145095.5469_r_single,144050.3438_r_single,142961.2812_r_single,141828.6406_r_single,140652.8125_r_single, & 139434.1406_r_single,138173.0000_r_single,136869.7500_r_single,135524.8438_r_single,134138.6250_r_single,132711.5625_r_single,131244.0625_r_single, & 129736.5781_r_single,128189.5938_r_single,126603.5469_r_single,124978.9453_r_single,123316.2656_r_single,121616.0312_r_single,119878.7500_r_single, & 118104.9531_r_single,116295.1719_r_single,114449.9844_r_single,112569.9062_r_single,110655.5625_r_single,108707.5000_r_single,106726.3281_r_single, & 104712.6406_r_single,102667.0625_r_single,100590.2188_r_single,98482.71875_r_single,96345.23438_r_single,94178.39062_r_single,91982.86719_r_single, & 89759.32031_r_single,87508.42969_r_single,85230.89062_r_single,82927.38281_r_single,80598.62500_r_single,78245.29688_r_single,75868.14844_r_single, & 73467.88281_r_single,71045.23438_r_single,68600.96094_r_single,66135.78906_r_single,63650.46094_r_single,61145.74609_r_single,58622.40625_r_single, & 56081.21094_r_single,53522.93750_r_single,50948.35938_r_single,48358.25781_r_single,45753.42188_r_single,43134.64844_r_single,40502.74219_r_single, & 37858.51172_r_single,35202.73047_r_single,32536.22656_r_single,29859.81250_r_single,27174.30469_r_single,24480.51758_r_single,21779.29102_r_single, & 19071.41211_r_single,16357.72461_r_single,13639.05469_r_single,10916.22852_r_single,8190.078125_r_single,5461.452148_r_single,2731.143066_r_single, & 0.0000000000E+00_r_single,2731.143066_r_single /) ! print *,'size(dx)=',size(dx),'jm+2=',gfile%dimy+2,'size(gfile%dx)=',size(gfile%dx), & ! maxval(gfile%dx),minval(gfile%dx),maxval(gfile%dy),maxval(gfile%dy),'nframe=', & ! gfile%nframe,'dimy=',gfile%dimy if(allocated(gfile%dx).and.size(gfile%dx)==183*(gfile%dimx+2*gfile%nframe)) then do i=1,gfile%dimy+2*gfile%nframe gfile%dx((i-ione)*(gfile%dimx+2*gfile%nframe)+ione:i*(gfile%dimx+2*gfile%nframe))=dx(i) enddo endif endif deallocate(dx) if(.not.present(recname).or..not.present(reclevtyp).or..not.present(reclev) )then if(size(gfile%recname)==86_i_kind+20*gfile%dimz+(gfile%dimz+ione)+3*gfile%nsoil+4_i_kind) then rec=ione gfile%recname(1)='hgt' gfile%recname(2)='glat' gfile%recname(3)='glon' gfile%recname(4)='dpres' gfile%recname(5)='vlat' gfile%recname(6)='vlon' gfile%recname(7)='acfrcv' gfile%recname(8)='acfrst' gfile%recname(9)='acprec' gfile%recname(10)='acsnom' gfile%recname(11)='acsnow' gfile%recname(12)='akhs_out' gfile%recname(13)='akms_out' gfile%recname(14)='albase' gfile%recname(15)='albedo' gfile%recname(16)='alwin' gfile%recname(17)='alwout' gfile%recname(18)='alwtoa' gfile%recname(19)='aswin' gfile%recname(20)='aswout' gfile%recname(21)='aswtoa' gfile%recname(22)='bgroff' gfile%recname(23)='cfrach' gfile%recname(24)='cfracl' gfile%recname(25)='cfracm' gfile%recname(26)='cldefi' gfile%recname(27)='cmc' gfile%recname(28)='cnvbot' gfile%recname(29)='cnvtop' gfile%recname(30)='cprate' gfile%recname(31)='cuppt' gfile%recname(32)='cuprec' gfile%recname(33)='czen' gfile%recname(34)='czmean' gfile%recname(35)='epsr' gfile%recname(36)='grnflx' gfile%recname(37)='hbotd' gfile%recname(38)='hbots' gfile%recname(39)='htopd' gfile%recname(40)='htops' gfile%recname(41)='mxsnal' gfile%recname(42)='pblh' gfile%recname(43)='potevp' gfile%recname(44)='prec' gfile%recname(45)='pshltr' gfile%recname(46)='q10' gfile%recname(47)='qsh' gfile%recname(48)='qshltr' gfile%recname(49)='qwbs' gfile%recname(50)='qz0' gfile%recname(51)='radot' gfile%recname(52)='rlwin' gfile%recname(53)='rlwtoa' gfile%recname(54)='rswin' gfile%recname(55)='rswinc' gfile%recname(56)='rswout' gfile%recname(57)='sfcevp' gfile%recname(58)='sfcexc' gfile%recname(59)='sfclhx' gfile%recname(60)='sfcshx' gfile%recname(61)='si' gfile%recname(62)='sice' gfile%recname(63)='sigt4' gfile%recname(64)='sm' gfile%recname(65)='smstav' gfile%recname(66)='smstot' gfile%recname(67)='sno' gfile%recname(68)='snopcx' gfile%recname(69)='soiltb' gfile%recname(70)='sr' gfile%recname(71)='ssroff' gfile%recname(72)='tsea' gfile%recname(73)='subshx' gfile%recname(74)='tg' gfile%recname(75)='th10' gfile%recname(76)='ths' gfile%recname(77)='thz0' gfile%recname(78)='tshltr' gfile%recname(79)='twbs' gfile%recname(80)='u10' gfile%recname(81)='uustar' gfile%recname(82)='uz0' gfile%recname(83)='v10' gfile%recname(84)='vfrac' gfile%recname(85)='vz0' gfile%recname(86)='zorl' rec=86_i_kind gfile%recname(rec+ione:rec+gfile%dimz)='vvel' gfile%recname(rec+gfile%dimz+ione:rec+2*gfile%dimz)='dwdt' gfile%recname(rec+2*gfile%dimz+ione:rec+3*gfile%dimz+ione)='pres' gfile%recname(rec+3*gfile%dimz+2_i_kind:rec+4*gfile%dimz+ione)='omgalf' gfile%recname(rec+4*gfile%dimz+2_i_kind:rec+5*gfile%dimz+ione)='rrw' gfile%recname(rec+5*gfile%dimz+2_i_kind:rec+6*gfile%dimz+ione)='cldfra' gfile%recname(rec+6*gfile%dimz+2_i_kind:rec+7*gfile%dimz+ione)='clwmr' gfile%recname(rec+7*gfile%dimz+2_i_kind:rec+8*gfile%dimz+ione)='exch_h' gfile%recname(rec+8*gfile%dimz+2_i_kind:rec+9*gfile%dimz+ione)='spfh' gfile%recname(rec+9*gfile%dimz+2_i_kind:rec+10*gfile%dimz+ione)='q2' gfile%recname(rec+10*gfile%dimz+2_i_kind:rec+11*gfile%dimz+ione)='rlwtt' gfile%recname(rec+11*gfile%dimz+2_i_kind:rec+12*gfile%dimz+ione)='rswtt' gfile%recname(rec+12*gfile%dimz+2_i_kind:rec+13*gfile%dimz+ione)='tmp' gfile%recname(rec+13*gfile%dimz+2_i_kind:rec+14*gfile%dimz+ione)='tcucn' gfile%recname(rec+14*gfile%dimz+2_i_kind:rec+15*gfile%dimz+ione)='train' gfile%recname(rec+15*gfile%dimz+2_i_kind:rec+16*gfile%dimz+ione)='ugrd' gfile%recname(rec+16*gfile%dimz+2_i_kind:rec+17*gfile%dimz+ione)='vgrd' gfile%recname(rec+17*gfile%dimz+2_i_kind:rec+18*gfile%dimz+ione)='xlen_mix' gfile%recname(rec+18*gfile%dimz+2_i_kind:rec+19*gfile%dimz+ione)='f_ice' gfile%recname(rec+19*gfile%dimz+2_i_kind:rec+20*gfile%dimz+ione)='f_rimef' gfile%recname(rec+20*gfile%dimz+2_i_kind:rec+21*gfile%dimz+ione)='f_rain' gfile%recname(rec+21*gfile%dimz+2_i_kind:rec+21*gfile%dimz+gfile%nsoil+ione)='sh2o' gfile%recname(rec+21*gfile%dimz+gfile%nsoil+2_i_kind:rec+21*gfile%dimz+2*gfile%nsoil+ione)='smc' gfile%recname(rec+21*gfile%dimz+2*gfile%nsoil+2_i_kind:rec+21*gfile%dimz+3*gfile%nsoil+ione)='stc' gfile%recname(rec+21*gfile%dimz+3*gfile%nsoil+2_i_kind)='sltyp' gfile%recname(rec+21*gfile%dimz+3*gfile%nsoil+3_i_kind)='vgtyp' gfile%recname(rec+21*gfile%dimz+3*gfile%nsoil+4_i_kind)='cfrcv' gfile%recname(rec+21*gfile%dimz+3*gfile%nsoil+5_i_kind)='cfrst' endif !define rec layer type if(size(gfile%reclevtyp)==86_i_kind+20*gfile%dimz+(gfile%dimz+ione)+3*gfile%nsoil+4_i_kind) then gfile%reclevtyp='sfc' gfile%reclevtyp(4)='hybrid sig lev' gfile%reclevtyp(46)='10 m above gnd' gfile%reclevtyp(75)='10 m above gnd' gfile%reclevtyp(80)='10 m above gnd' gfile%reclevtyp(83)='10 m above gnd' rec=86_i_kind gfile%reclevtyp(rec+ione:rec+gfile%dimz)='mid layer' gfile%reclevtyp(rec+gfile%dimz+ione:rec+2*gfile%dimz)='mid layer' gfile%reclevtyp(rec+2*gfile%dimz+ione:rec+3*gfile%dimz+ione)='layer' gfile%reclevtyp(rec+3*gfile%dimz+2_i_kind:rec+4*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+4*gfile%dimz+2_i_kind:rec+5*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+5*gfile%dimz+2_i_kind:rec+6*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+6*gfile%dimz+2_i_kind:rec+7*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+7*gfile%dimz+2_i_kind:rec+8*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+8*gfile%dimz+2_i_kind:rec+9*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+9*gfile%dimz+2_i_kind:rec+10*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+10*gfile%dimz+2_i_kind:rec+11*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+11*gfile%dimz+2_i_kind:rec+12*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+12*gfile%dimz+2_i_kind:rec+13*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+13*gfile%dimz+2_i_kind:rec+14*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+14*gfile%dimz+2_i_kind:rec+15*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+15*gfile%dimz+2_i_kind:rec+16*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+16*gfile%dimz+2_i_kind:rec+17*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+17*gfile%dimz+2_i_kind:rec+18*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+18*gfile%dimz+2_i_kind:rec+19*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+19*gfile%dimz+2_i_kind:rec+20*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+20*gfile%dimz+2_i_kind:rec+21*gfile%dimz+ione)='mid layer' gfile%reclevtyp(rec+21*gfile%dimz+2_i_kind)='0-10 cm down' gfile%reclevtyp(rec+21*gfile%dimz+3_i_kind)='10-40 cm down' gfile%reclevtyp(rec+21*gfile%dimz+4_i_kind)='40-100 cm down' gfile%reclevtyp(rec+21*gfile%dimz+5_i_kind)='100-200 cm down' gfile%reclevtyp(rec+21*gfile%dimz+gfile%nsoil+2_i_kind)='0-10 cm down' gfile%reclevtyp(rec+21*gfile%dimz+gfile%nsoil+3_i_kind)='10-40 cm down' gfile%reclevtyp(rec+21*gfile%dimz+gfile%nsoil+4_i_kind)='40-100 cm down' gfile%reclevtyp(rec+21*gfile%dimz+gfile%nsoil+5_i_kind)='100-200 cm down' gfile%reclevtyp(rec+21*gfile%dimz+2*gfile%nsoil+2_i_kind)='0-10 cm down' gfile%reclevtyp(rec+21*gfile%dimz+2*gfile%nsoil+3_i_kind)='10-40 cm down' gfile%reclevtyp(rec+21*gfile%dimz+2*gfile%nsoil+4_i_kind)='40-100 cm down' gfile%reclevtyp(rec+21*gfile%dimz+2*gfile%nsoil+5_i_kind)='100-200 cm down' endif ! !reclev if(size(gfile%reclev)==86_i_kind+20*gfile%dimz+(gfile%dimz+ione)+3*gfile%nsoil+4_i_kind) then gfile%reclev=ione rec=86_i_kind do j=1,3 do i=1,gfile%dimz gfile%reclev(rec+(j-ione)*gfile%dimz+i)=i enddo enddo gfile%reclev(rec+3*gfile%dimz+ione)=gfile%dimz+1 do j=4,21 do i=1,gfile%dimz gfile%reclev(rec+(j-ione)*gfile%dimz+ione+i)=i enddo enddo rec=rec+21*gfile%dimz+ione do j=22,24 do i=1,gfile%nsoil gfile%reclev(rec+(j-22_i_kind)*gfile%nsoil+i)=i enddo enddo endif ! endif else if ( gfile%modelname == "GSI" .and.linit) then ! gfile%arycname(1)='recunit' gfile%aryclen(1)=gfile%nrec allocate(gfile%arycval(maxval(gfile%aryclen),gfile%nmetaaryc)) gfile%arycval(1,1)='pgm' gfile%arycval(2,1)='nondim' gfile%arycval(3:gfile%dimz+2_i_kind,1)='K' gfile%arycval(gfile%dimz+3_i_kind:3*gfile%dimz+2_i_kind,1)='m/s ' gfile%arycval(3*gfile%dimz+3_i_kind:6*gfile%dimz+2_i_kind,1)='kg/kg ' gfile%arycval(6*gfile%dimz+3_i_kind,1)='%' gfile%arycval(6*gfile%dimz+4_i_kind,1)='K' gfile%arycval(6*gfile%dimz+5_i_kind,1)='kg/m2 ' gfile%arycval(6*gfile%dimz+6_i_kind,1)='integer' gfile%arycval(6*gfile%dimz+7_i_kind,1)='% ' gfile%arycval(6*gfile%dimz+8_i_kind,1)='integer' gfile%arycval(6*gfile%dimz+9_i_kind,1)='integer' gfile%arycval(6*gfile%dimz+10_i_kind,1)='m ' gfile%arycval(6*gfile%dimz+11_i_kind,1)='K ' gfile%arycval(6*gfile%dimz+12_i_kind,1)='% ' if(.not.present(recname).or..not.present(reclevtyp).or..not.present(reclev) )then ! if(size(gfile%recname)==10_i_kind+3*gfile%dimz+gfile%ntrac*gfile%dimz .and. & size(gfile%reclevtyp)==10_i_kind+3*gfile%dimz+gfile%ntrac*gfile%dimz .and. & size(gfile%reclev)==10_i_kind+3*gfile%dimz+gfile%ntrac*gfile%dimz )then gfile%reclevtyp='sfc' gfile%reclev=ione gfile%recname(1)='hgt' gfile%recname(2)='pres' rec=2_i_kind gfile%recname(rec+ione:rec+gfile%dimz)='tmp' gfile%reclevtyp(rec+ione:rec+gfile%dimz)='mid layer' gfile%recname(rec+gfile%dimz+ione:rec+2*gfile%dimz)='ugrd' gfile%reclevtyp(rec+gfile%dimz+ione:rec+2*gfile%dimz)='mid layer' gfile%recname(rec+2*gfile%dimz+ione:rec+3*gfile%dimz)='vgrd' gfile%reclevtyp(rec+2*gfile%dimz+ione:rec+3*gfile%dimz)='mid layer' do i=1,3 do j=1,gfile%dimz gfile%reclev(rec+(i-ione)*gfile%dimz+j)=j enddo enddo do i=1,gfile%ntrac if ( i==ione) gfile%recname(rec+(2_i_kind+i)*gfile%dimz+ione:rec+(3_i_kind+i)*gfile%dimz)='spfh' if ( i==ione) gfile%reclevtyp(rec+(2_i_kind+i)*gfile%dimz+ione:rec+(3_i_kind+i)*gfile%dimz)='mid layer' if ( i==2_i_kind) gfile%recname(rec+(2_i_kind+i)*gfile%dimz+ione:rec+(3_i_kind+i)*gfile%dimz)='o3mr' if ( i==2_i_kind) gfile%reclevtyp(rec+(2_i_kind+i)*gfile%dimz+ione:rec+(3_i_kind+i)*gfile%dimz)='mid layer' if ( i==3_i_kind) gfile%recname(rec+(2_i_kind+i)*gfile%dimz+ione:rec+(3_i_kind+i)*gfile%dimz)='clwmr' if ( i==3_i_kind) gfile%reclevtyp(rec+(2_i_kind+i)*gfile%dimz+ione:rec+(3_i_kind+i)*gfile%dimz)='mid layer' do j=1,gfile%dimz gfile%reclev(rec+(2_i_kind+i)*gfile%dimz+j)=j enddo enddo rec=rec+3*gfile%dimz+gfile%ntrac*gfile%dimz gfile%recname(rec+ione)='f10m' gfile%recname(rec+2_i_kind)='tsea' gfile%recname(rec+3_i_kind)='sheleg' gfile%recname(rec+4_i_kind)='vtype' gfile%recname(rec+5_i_kind)='vfrac' gfile%recname(rec+6_i_kind)='stype' gfile%recname(rec+7_i_kind)='slmsk' gfile%recname(rec+8_i_kind)='zorl' gfile%recname(rec+9_i_kind)='stc' gfile%recname(rec+10_i_kind)='smc' gfile%reclevtyp(rec+9_i_kind:rec+10_i_kind)='soil layer' endif ! endif endif !jw print *,' end of gfinit' ! iret=izero end subroutine nemsio_gfinit !------------------------------------------------------------------------------ subroutine nemsio_stop() !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_stop ! prgmmr: ! ! abstract: stop ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none stop end subroutine nemsio_stop !------------------------------------------------------------------------------ ! temporary subroutines for basio file unit subroutine nemsio_getlu(gfile,gfname,gaction,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_getlu ! prgmmr: ! ! abstract: set unit number to the first number available between 600-699 ! according to unit number array fileunit ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! gfname,gaction ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile character*(*) ,intent(in ) :: gfname,gaction integer(i_kind) ,intent( out) :: iret integer(i_kind) :: i iret=-10_i_kind gfile%gfname=gfname gfile%gaction=gaction do i=600,699 if ( fileunit(i) == izero ) then gfile%flunit=i fileunit(i)=i iret=izero exit endif enddo end subroutine nemsio_getlu !------------------------------------------------------------------------------ ! temporary subroutines for free unit number subroutine nemsio_clslu(gfile,iret) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_clslu ! prgmmr: ! ! abstract: free unit number array index corresponding to unit number ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! gfile ! ! output argument list: ! gfile ! iret ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(nemsio_gfile),intent(inout) :: gfile integer(i_kind) ,intent( out) :: iret iret=-10_i_kind if ( fileunit(gfile%flunit) /= izero ) then fileunit(gfile%flunit)=izero gfile%flunit=izero iret=izero endif end subroutine nemsio_clslu !------------------------------------------------------------------------------ SUBROUTINE nemsio_splat4(IDRT,JMAX,ASLAT) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_splat4 ! prgmmr: ! ! abstract: ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! idrt,jmax ! ! output argument list: ! ASLAT ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none integer(i_kind),intent(in ) :: idrt,jmax real(r_single) ,intent( out) :: ASLAT(JMAX) INTEGER(i_kind),PARAMETER:: KD=SELECTED_REAL_KIND(15,45) REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2) REAL(KIND=KD):: ASLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP) integer(i_kind),PARAMETER:: JZ=50_i_kind REAL(r_kind) BZ(JZ) DATA BZ / 2.4048255577_r_kind, 5.5200781103_r_kind, & 8.6537279129_r_kind, 11.7915344391_r_kind, 14.9309177086_r_kind, 18.0710639679_r_kind, & 21.2116366299_r_kind, 24.3524715308_r_kind, 27.4934791320_r_kind, 30.6346064684_r_kind, & 33.7758202136_r_kind, 36.9170983537_r_kind, 40.0584257646_r_kind, 43.1997917132_r_kind, & 46.3411883717_r_kind, 49.4826098974_r_kind, 52.6240518411_r_kind, 55.7655107550_r_kind, & 58.9069839261_r_kind, 62.0484691902_r_kind, 65.1899648002_r_kind, 68.3314693299_r_kind, & 71.4729816036_r_kind, 74.6145006437_r_kind, 77.7560256304_r_kind, 80.8975558711_r_kind, & 84.0390907769_r_kind, 87.1806298436_r_kind, 90.3221726372_r_kind, 93.4637187819_r_kind, & 96.6052679510_r_kind, 99.7468198587_r_kind, 102.888374254_r_kind, 106.029930916_r_kind, & 109.171489649_r_kind, 112.313050280_r_kind, 115.454612653_r_kind, 118.596176630_r_kind, & 121.737742088_r_kind, 124.879308913_r_kind, 128.020877005_r_kind, 131.162446275_r_kind, & 134.304016638_r_kind, 137.445588020_r_kind, 140.587160352_r_kind, 143.728733573_r_kind, & 146.870307625_r_kind, 150.011882457_r_kind, 153.153458019_r_kind, 156.295034268_r_kind / REAL(r_kind):: DLT INTEGER(i_kind):: JHE,JHO real(r_kind),PARAMETER :: PI=3.14159265358979_r_kind,C=(one-(two/PI)**2)*quarter real(r_kind) r integer(i_kind) jh,n,j !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !C GAUSSIAN LATITUDES ! print *,'nemsio_module,in SPLAT4',IDRT,JMAX IF(IDRT==4_i_kind) THEN JH=JMAX/2 JHE=(JMAX+ione)/2 R=one/SQRT((JMAX+half)**2+C) DO J=1,MIN(JH,JZ) ASLATD(J)=COS(BZ(J)*R) ENDDO DO J=JZ+ione,JH ASLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R) ENDDO SPMAX=one DO WHILE(SPMAX>EPS) SPMAX=zero DO J=1,JH PKM1(J)=one PK(J)=ASLATD(J) ENDDO DO N=2,JMAX DO J=1,JH PKM2(J)=PKM1(J) PKM1(J)=PK(J) PK(J)=((2*N-ione)*ASLATD(J)*PKM1(J)-(N-ione)*PKM2(J))/N ENDDO ENDDO DO J=1,JH SP=PK(J)*(one-ASLATD(J)**2)/(JMAX*(PKM1(J)-ASLATD(J)*PK(J))) ASLATD(J)=ASLATD(J)-SP SPMAX=MAX(SPMAX,ABS(SP)) ENDDO ENDDO !CDIR$ IVDEP DO J=1,JH ASLAT(J)=ASLATD(J) ASLAT(JMAX+ione-J)=-ASLAT(J) ENDDO IF(JHE>JH) THEN ASLAT(JHE)=zero ENDIF !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !C EQUALLY-SPACED LATITUDES INCLUDING POLES ELSEIF(IDRT==izero) THEN JH=JMAX/2 JHE=(JMAX+ione)/2 JHO=JHE-ione DLT=PI/(JMAX-ione) ASLAT(1)=one DO J=2,JH ASLAT(J)=COS((J-ione)*DLT) ENDDO !CDIR$ IVDEP DO J=1,JH ASLAT(JMAX+ione-J)=-ASLAT(J) ENDDO IF(JHE>JH) THEN ASLAT(JHE)=zero ENDIF !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !C EQUALLY-SPACED LATITUDES EXCLUDING POLES ELSEIF(IDRT==256_i_kind) THEN JH=JMAX/2 JHE=(JMAX+ione)/2 JHO=JHE DLT=PI/JMAX ASLAT(1)=one DO J=1,JH ASLAT(J)=COS((J-half)*DLT) ENDDO !CDIR$ IVDEP DO J=1,JH ASLAT(JMAX+ione-J)=-ASLAT(J) ENDDO IF(JHE>JH) THEN ASLAT(JHE)=zero ENDIF ENDIF !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_splat4 !---------------------------------------------------------------------- SUBROUTINE nemsio_splat8(IDRT,JMAX,ASLAT) !$$$ subprogram documentation block ! . . . . ! subprogram: nemsio_splat8 ! prgmmr: ! ! abstract: ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! idrt,jmax ! ! output argument list: ! ASLAT ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none integer(i_kind),intent(in ) :: idrt,jmax real(r_kind) ,intent( out) :: ASLAT(JMAX) INTEGER(i_kind),PARAMETER:: KD=SELECTED_REAL_KIND(15,45) REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2) REAL(KIND=KD):: ASLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP) integer(i_kind),PARAMETER:: JZ=50_i_kind REAL(r_kind) BZ(JZ) DATA BZ / 2.4048255577_r_kind, 5.5200781103_r_kind, & 8.6537279129_r_kind, 11.7915344391_r_kind, 14.9309177086_r_kind, 18.0710639679_r_kind, & 21.2116366299_r_kind, 24.3524715308_r_kind, 27.4934791320_r_kind, 30.6346064684_r_kind, & 33.7758202136_r_kind, 36.9170983537_r_kind, 40.0584257646_r_kind, 43.1997917132_r_kind, & 46.3411883717_r_kind, 49.4826098974_r_kind, 52.6240518411_r_kind, 55.7655107550_r_kind, & 58.9069839261_r_kind, 62.0484691902_r_kind, 65.1899648002_r_kind, 68.3314693299_r_kind, & 71.4729816036_r_kind, 74.6145006437_r_kind, 77.7560256304_r_kind, 80.8975558711_r_kind, & 84.0390907769_r_kind, 87.1806298436_r_kind, 90.3221726372_r_kind, 93.4637187819_r_kind, & 96.6052679510_r_kind, 99.7468198587_r_kind, 102.888374254_r_kind, 106.029930916_r_kind, & 109.171489649_r_kind, 112.313050280_r_kind, 115.454612653_r_kind, 118.596176630_r_kind, & 121.737742088_r_kind, 124.879308913_r_kind, 128.020877005_r_kind, 131.162446275_r_kind, & 134.304016638_r_kind, 137.445588020_r_kind, 140.587160352_r_kind, 143.728733573_r_kind, & 146.870307625_r_kind, 150.011882457_r_kind, 153.153458019_r_kind, 156.295034268_r_kind / REAL(r_kind):: DLT INTEGER(i_kind):: JHE,JHO real(r_kind),PARAMETER :: PI=3.14159265358979_r_kind,C=(one-(two/PI)**2)*quarter real(r_kind) r integer(i_kind) jh,n,j !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !C GAUSSIAN LATITUDES IF(IDRT==4_i_kind) THEN JH=JMAX/2 JHE=(JMAX+ione)/2 R=one/SQRT((JMAX+half)**2+C) DO J=1,MIN(JH,JZ) ASLATD(J)=COS(BZ(J)*R) ENDDO DO J=JZ+ione,JH ASLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R) ENDDO SPMAX=one DO WHILE(SPMAX>EPS) SPMAX=zero DO J=1,JH PKM1(J)=one PK(J)=ASLATD(J) ENDDO DO N=2,JMAX DO J=1,JH PKM2(J)=PKM1(J) PKM1(J)=PK(J) PK(J)=((2*N-ione)*ASLATD(J)*PKM1(J)-(N-ione)*PKM2(J))/N ENDDO ENDDO DO J=1,JH SP=PK(J)*(one-ASLATD(J)**2)/(JMAX*(PKM1(J)-ASLATD(J)*PK(J))) ASLATD(J)=ASLATD(J)-SP SPMAX=MAX(SPMAX,ABS(SP)) ENDDO ENDDO !CDIR$ IVDEP DO J=1,JH ASLAT(J)=ASLATD(J) ASLAT(JMAX+ione-J)=-ASLAT(J) ENDDO IF(JHE>JH) THEN ASLAT(JHE)=zero ENDIF !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !C EQUALLY-SPACED LATITUDES INCLUDING POLES ELSEIF(IDRT==izero) THEN JH=JMAX/2 JHE=(JMAX+ione)/2 JHO=JHE-ione DLT=PI/(JMAX-ione) ASLAT(1)=one DO J=2,J ASLAT(J)=COS((J-ione)*DLT) ENDDO !CDIR$ IVDEP DO J=1,JH ASLAT(JMAX+ione-J)=-ASLAT(J) ENDDO IF(JHE>JH) THEN ASLAT(JHE)=zero ENDIF !C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !C EQUALLY-SPACED LATITUDES EXCLUDING POLES ELSEIF(IDRT==256_i_kind) THEN JH=JMAX/2 JHE=(JMAX+ione)/2 JHO=JHE DLT=PI/JMAX ASLAT(1)=one DO J=1,JH ASLAT(J)=COS((J-half)*DLT) ENDDO !DIR$ IVDEP DO J=1,JH ASLAT(JMAX+ione-J)=-ASLAT(J) ENDDO IF(JHE>JH) THEN ASLAT(JHE)=zero ENDIF ENDIF ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_splat8 !------------------------------------------------------------------------------ ! elemental function equal_str_nocase(str1,str2) !$$$ subprogram documentation block ! . . . . ! subprogram: equal_str_nocase ! prgmmr: ! ! abstract: convert a word to lower case ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! str1 ! str2 ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none Character (len=*) , intent(in) :: str1 Character (len=*) , intent(in) :: str2 logical :: equal_str_nocase integer(i_kind) :: i,ic1,ic2,nlen nlen = len(str2) ! if(len(str1)/=nlen) then equal_str_nocase=.false. return endif equal_str_nocase=.false. do i=1,nlen ic1 = ichar(str1(i:i)) if (ic1 >= 65_i_kind .and. ic1 < 91_i_kind) ic1 = ic1+32_i_kind ic2 = ichar(str2(i:i)) if (ic2 >= 65_i_kind .and. ic2 < 91_i_kind) ic2 = ic2+32_i_kind if(ic1/=ic2) then equal_str_nocase=.false. return endif end do equal_str_nocase=.true. ! !----------------------------------------------------------------------- ! end function equal_str_nocase ! !----------------------------------------------------------------------- ! elemental function lowercase(word) !$$$ subprogram documentation block ! . . . . ! subprogram: lowercase ! prgmmr: ! ! abstract: convert a word to lower case ! ! program history log: ! 2009-08-31 lueken - added subprogram doc block ! ! input argument list: ! word ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none Character (len=*) , intent(in) :: word Character (len=32) :: lowercase integer(i_kind) :: i,ic,nlen nlen = len(word) if(nlen >32_i_kind) then nlen=32_i_kind endif lowercase(1:nlen)=word(1:nlen) do i=1,nlen ic = ichar(word(i:i)) if (ic >= 65_i_kind .and. ic < 91_i_kind) lowercase(i:i) = char(ic+32_i_kind) end do if(nlen<32_i_kind) lowercase(nlen+ione:)=' ' ! !----------------------------------------------------------------------- ! end function lowercase ! !---------------------------------------------------------------------- end module nemsio_module